MODULE MBUFR !****************************************************************************** !* MODULO MBUFR-ADT * !* * !* Module to Encode/Decode Meteorological Data in the FM94-BUFR * !* using Abstract Data Type * !* Copyright (C) 2005 Sergio Henrique S. Ferreira * !* * !* This library is free software; you can redistribute it and/or * !* modify it under the terms of the GNU Lesser General Public * !* License as published by the Free Software Foundation; either * !* version 2.1 of the License, or (at your option) any later version. * !* * !* This library is distributed in the hope that it will be useful, * !* but WITHOUT ANY WARRANTY; without even the implied warranty of * !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * !* Lesser General Public License for more details. * !* * !****************************************************************************** !* MODULO MBUFR-ADT * !* * !* MODULO PARA CODIFICAR E DECODIFICAR DADOS METEOROLOGICOS EM FM94-BUFR * !* UTILIZANDO TIPOS DE DADOS ABSTRATOS * !* * !* Copyright (C) 2005 Sergio Henrique S. Ferreira (SHSF) * !* * !* * !* Esta biblioteca e um software livre, que pode ser redistribuido e/ou * !* modificado sob os termos da Licenca Publica Geral Reduzida GNU, * !* conforme publicada pela Free Software Foundation, versao 2.1 da licenca* !* ou (a crit�rio do autor) qualquer vers�o posterior. * !* * !* Esta biblioteca e distribuida na esperanca de ser util, porem NAO TEM * !* NENHUMA GARANTIA EXPLICITA OU IMPLICITA, COMERCIAL OU DE ATENDIMENTO * !* A UMA DETERMINADA FINALIDADE. Veja a Licenca Publica Geral Reduzida * !* GNU para maiores detalhes. * !* * !****************************************************************************** ! ! 1- SUB-ROTINAS PUBLICAS ! As rotinas publicas fornecidas por este modulo sao: ! ! a) OPEN_MBUFR ! b) WRITE_MBUFR ! c) READ_MBUFR ! d) CLOSE_MBUFR ! ! A SUB-ROUTINA OPEN_MBUFR abre um arquivo BUFR de acesso aleatorio, para ! gravacao dos dados BUFR. Tambem inicia as estruturas de dados internas ! deste modulo, incluindo a tabela de descritores BUFR. ! ! A SUB-ROTINA WRITE_MBUFR Grava uma mensagem BUFR em um arquivo aberto por ! OPEN_MBUFR. ! ! A SUB-ROTINA READ_MBUFR Le uma mensagem BUFRS em um arquivo aberto por ! OPEN_MBUFR ! ! A SUBROUTINA CLOSE_MBUFR(UN) Fecha um arquivo BUFR aberto por OPEN_MBUFR ! ! ! 2- TIPOS DE DADOS PUBLICOS ! sec1TYPE ! sec2TYPE ! sec3TYPE ! sec4TYPE ! exlistTYPE ! ! 3 - DEPENDENCIAS EXTERNAS: SISTEMA_OPERACIONAL.getenv ! Notas: a) Para sistema unix e linux getenv nao precisa ser declarado ! b) Para sistema windows e� necessario incluir "USE MSFLIB" !------------------------------------------------------------------------------- ! REVISAO HISTORICA ! NOV2005 -v0.1- SHSF - Versao original compativel com os as edicoes BUFR Edicao:2 e BUFR Edicao: 3 ! JULHO2006 - SHSF - Corrigido BUG em Write_MBUFR. Em principio a variavel desc_sec4(:)%i=0 ! 20060803 - - SHSF - Corrigido Bug na leitura dos minutos da secao 1 ! 20060804 - - SHSF - Introduzido subrotina interna SAVESEC4RD - Gravacao BUFR com ! replicador posposto ! 20070118 - - SHSF - INIT_TABD: Eliminado a atribuicao de valores zeros em todos ! os termos de TABD(:,:,:,:) para otimizar a inicializacao ! desta tabela ! 20070202 -V1.5- SHSF - tabc_setparm: Modificacao no tratamento do erro 51 (remocao do "stop" ! para permitir que o programa prossiga. Obs.: E necessario verificar ! o processamento do descritor da tabela C 2-04-yyy, pois, eventualmente ! aparecem em mensagens SATEM pre-processadas !------------------------------------------------------------------------------- ! USE MSFLIB ! Para compilacao com Visual Fortran IMPLICIT NONE ! Todas as variaveis serao declaradas PRIVATE ! Todas as Variaveis, estruturas e subrotinas ! serao, em principio, privadas !{ Declara como PUBLICAS as seguintes subrotinas PUBLIC OPEN_MBUFR PUBLIC WRITE_MBUFR PUBLIC READ_MBUFR PUBLIC CLOSE_MBUFR !} !{ Declara como PUBLICAS os seguintes tipos de estruturas PUBLIC sec1TYPE PUBLIC sec2TYPE PUBLIC sec3TYPE PUBLIC sec4TYPE PUBLIC IOERR PUBLIC exmsgTYPE PUBLIC selectTYPE PUBLIC any PUBLIC none !} !{ Definicao dos tipos PRIVADOS DE DADOS TYPE exmsgTYPE INTEGER::bTYPE INTEGER::bsubTYPE END TYPE TYPE selectTYPE INTEGER::bTYPE INTEGER::bsubTYPE END TYPE TYPE MBUFR_init INTEGER :: center INTEGER :: MasterTable INTEGER :: LocalTable END TYPE TYPE descbufr INTEGER :: F INTEGER :: X INTEGER :: y INTEGER*2::i END TYPE TYPE tabcparm INTEGER :: dbits !Incremento do numero de bits valido p/ tabb%u=0 INTEGER :: dscale !Incremento do fator de escala p/ tabb%u=0 INTEGER :: vref ! Novo valor de referencia INTEGER :: nlocalbits ! Numero de bits de um descritor local inserido por 2-06-yyy END TYPE !} !{ Declaracao de TIPOS PUBLICOS de dados TYPE sec4TYPE REAL,pointer::r(:,:) ! Valor REAL (Usar este campo quando a variavel for do tipo numerico) INTEGER*2,pointer::c(:,:) ! Numero do caracter ou subdescritor (usar este campo quando for do tipo ASCII) INTEGER,pointer::d(:,:) ! Descritor INTEGER::nvars END TYPE TYPE sec3TYPE INTEGER,pointer::d(:) INTEGER :: ndesc INTEGER :: nsubsets INTEGER :: is_cpk INTEGER :: is_obs END TYPE TYPE sec1TYPE INTEGER :: bTYPE INTEGER :: bsubTYPE INTEGER :: center INTEGER :: subcenter INTEGER :: year INTEGER :: month INTEGER :: day INTEGER :: hour INTEGER :: minute INTEGER :: MasterTable INTEGER :: LocalTable LOGICAL :: sec2present END TYPE TYPE sec2TYPE CHARACTER(len=1),pointer:: oct(:) INTEGER::nocts END TYPE !{ Definicao estrutura PRIVATIVA para armazenar tabelas BUFR TYPE bufrtableTYPE REAL :: scale !.......................... Fator de Escala REAL :: refv !.......................Valor de Referencia INTEGER :: nbits !............................Numero de Bits INTEGER*2 :: u !................Tipo de Unidade do descritor !----------------------------------------------------------- ! u=0 : Unidade Fisica ou Valor Numerico ! u=1 : Caractere ! u=3 : Flagtable ! u=4 : CodeTable !----------------------------------------------------------- END TYPE !} !{ ALOCACAO DAS VARIAVEIS PUBLICAS INTEGER,DIMENSION(1:99)::IOERR ! IOERR(un)=IOSTAT da leitura de um arquivo na unidade (UN) ! Se IOERR(un)/=0 houve um erro de leitura (provavel fim de arquivo) ! ! Nota: O Fortran padrao nao possui um comando especifico para detectar "fins de arquivos" ! em arquivos de acesso direto. Para contornar o problema, foi adotado ! a estrategia de verificacao do parametro IOSTAT, do comando READ. ! O IOSTAT retorna 0 quando a leitura de um registro e bem sucedida. Quando ! se tenta ascessar um registro superior ao fim do arquivo, IOSTAT retorna um ! codigo de erro, que varia de compilador para compilador. Desta forma, ! a melhor solucao encontrada para detectar o fim do arquivo e verIFicar ! IOSTAT/=0, isto e, verIFicar se IOERR(UN)=/0 !} !{ ALOCACAO DAS VARIAVEIS GLOBAIS E PRIVATIVAS DO MODULO INTEGER::currentRG !................................Posicao Corrente no arquivo BUFR INTEGER::centre_mbufr !............................Codigo do Centro que gerou o BUFR INTEGER::verloctab !..........................................Versao da tabela local INTEGER::vermastertab !......................................Versao da tabela Master CHARACTER(len=5)::STATION_NUMBER INTEGER :: NMSG !.................................................Numero de mensagens CHARACTER (len=255)::subname !............Guarda nome da subrotina para fins de DEBUG REAL,PARAMETER :: Null=-340282300 !........................................valor nulo INTEGER,PARAMETER::none = -99 INTEGER,PARAMETER::any=-11 CHARACTER(len=255)::local_tables ! Local das tabelas BUFR definido na variavel de ambiente MBUFR_TABLES TYPE(tabcparm)::tabc INTEGER*2::BUFR_Edition CHARACTER(len=80),DIMENSION(99)::erromessage !} !{ ALOCACAO DA TABELAS BUFR B e D TYPE(bufrtableTYPE),DIMENSION(0:0,0:63,0:255)::tabb !...............................Tabela B TYPE(descbufr),DIMENSION(3:3,0:63,0:255,700)::tabd !................................Tabela D INTEGER,DIMENSION(3:3,0:63,0:255)::ndtabd! Numero de elementos p/ cada descritor da tabela D ! Nota: As tabelas sao diminsionais em funcao do numero de bits ! que ocupa os termos f,x,y dos descritores ! f tem 2 bitd ! x tem 6 bits = 111111 = 63 ! y tem 8 bits = 11111111 = 255 !} !---------------------------------------------------------------------------------- CONTAINS ! ----------------------------------------------------------------------------! ! SUBROUTINE PUBLICA: MBUFR.OPEN_MBUFR | SHSF! ! ----------------------------------------------------------------------------! ! ! ABRI UM ARQUIVO BUFR e INICIALIZA TODAS AS TABELAS ! E VARIAVEIS UTILIZADAS PELO MODULO ! ! ----------------------------------------------------------------------------! ! Chamadas Externas: Sistema_Operacional.getenv ! ! Chamadas Internas: INIT_TABB,INIT_TABD,INIT_ERROMESSAGE ! !-----------------------------------------------------------------------------! SUBROUTINE OPEN_MBUFR(UN,filename,centre,MasterTable,LocalTable,BUFRED) !{ Variaveis da Interface INTEGER,intent(in)::un !..................Unidade Logica para gravacao CHARACTER(len=*),intent(in)::filename !.................Nome do arquivo INTEGER,intent(in)::centre !...................Codigo do Centro Gerados INTEGER,intent(in)::MasterTable INTEGER,intent(in)::LocalTable INTEGER,optional,intent(in)::BUFRED !......................EDICAO BUFR !} !{ Variaveis locais INTEGER::uni !................................Variaavel auxiliar de UN !} uni=un VerMasterTab=MasterTable VerLocTab=LocalTable centre_mbufr=centre currentRG=0 NMSG=0 IF (present(BUFRED)) THEN BUFR_Edition=BUFRED ELSE BUFR_Edition=3 END IF print *,"" print *,"+-----------+----------------------------------------+" print *,"| MBUFR-ADT | Module to encode and decode FM-94 BUFR |" Print *,"| | SHSF - VERSION 1.5 2007 |" print *,"+-----------+----------------------------------------+" call getenv("MBUFR_TABLES",local_tables) call INIT_TABB(Uni) ! Carrega tabela BUFR em TABB call INIT_TABD(Uni) ! Carrega tabela BUFR em TABD call INIT_ERROMESSAGE print *, " " print *," MBUFR-ADT: OPEN ",trim(filename), " AS #",UNI open(uni,file=filename,STATUS='unknown',FORM='UNFORMATTED',access='DIRECT',recl=1) END SUBROUTINE OPEN_MBUFR ! ----------------------------------------------------------------------------! ! SUBROUTINE PUBLICA: MBUFR.WRITE_MBUFR | SHSF! ! ----------------------------------------------------------------------------! ! ! ! ! ! ESTA ROTINA GRAVA UMA MENSAGEM BUFR COMPOSTA POR 6 SECOES (de 0 a 5) ! ! ! ! Primeiramente e feito um salto de 8 bytes no arquivo, deixando espaco ! ! para a secao 0, que sera gravada no final ! ! ! ! Em seguida sao gravados as secoes de 1 a 5. que possuem os seguintes ! ! tamanhos ! ! secao 1 - 18 Bytes ! ! secao 2 - Variavel (Optional) ! ! secao 3 - Variavel (DepENDe do Numero de descritores ) ! ! secao 4 - Variavel (DepENDe das variaveis e do numero de sub-grupos) ! ! secao 5 - 4 bytes "7777" ! ! ! ! Apos a gravacao destas secoes e feito o calculo do tamanho da mensagem ! ! que ee gravado na secao 0 ! ! ! ! Alguns testes de tamanho tambem saao REALidados ! ! ! ! ----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas: ! ! savesec1,savesec2,savesec3,savesec4b,savesec4rd,savesec4cmp expanddesc3 ! ! ! ----------------------------------------------------------------------------! SUBROUTINE write_mbufr(un,sec1,sec3,sec4,optsec) !{ VARIAVEIS DA INTERFACE EXTERNA INTEGER,intent(in)::UN TYPE(sec1TYPE)::sec1 TYPE(sec3TYPE)::sec3 TYPE(sec4TYPE)::sec4 TYPE(sec2TYPE),optional:: optsec !} !{ DEFINICOES DE VARIAVEIS LOCAIS !Aqui sao declarados os vetores que contem os descritores compactos para a secao3 !(desc_sec3) e os descritores expandidos para a secao 4(desc_sec4). ! ! O tamanho de desc_sec3 e igual a ndesc, pois os descritores compacto, sao ! os mesmos que sao fornecidos pelo programa principal ! ! O tamanho de desc_sec4 pode ser bem maior que ndesc. DepENDe da utilizacao ! de replicadores. Note que o numero de descritores expandidos tem que ! ser igual ao numero de variaveis fornecidas pelo programa principal, contudo ! por seguranca declaramos a dimensao de desc_sec3 como nvars+100. ! !{ TYPE(descbufr),pointer,DIMENSION(:)::desc_sec3 ! Descritores da secao3 (ndesc) TYPE(descbufr),pointer,DIMENSION(:)::desc_sec4 ! Descritores expandidos (secao 4) ! } ! Declaracao das demais variaveis locais !{ LOGICAL::sec2opt !- Se verdadeiro a secao 2 sera gravada INTEGER Tam_BUFR !-Tamanho total do arquivo BUFR (grav. na secao 1) INTEGER Tam_sec2 !-Numero de bytes da secao 2 INTEGER Tam_sec3 !-Numero de bytes da secao 3 INTEGER Tam_sec4 !-Numero de bytes da secao 4 INTEGER BTYPE,BSUBTYPE INTEGER :: auxi ! Variavel auxiliar para numeros inteiros CHARACTER(len=6) ::auxc ! Variavel auxiliar para caracteres INTEGER :: err !- Codigo de erro INTEGER :: ndesc_sec4 !- Numeto de descritores para secao4 INTEGER :: IFinal !- Numero de descritores expandidos ate o primeiro replicador posposto. INTEGER :: ndxmax ! Numero maximo de descritores da secao 4 INTEGER :: UNI ! Numero da Unidade Loogica de Gravacaao INTEGER :: aerr INTEGER :: RG0,RGF,NRG ! RG de Inicio, Fim e Numero de RG de uma ! Mensagem BUFR INTEGER :: RG2 ! Registro de Inicio da Secao 2 LOGICAL :: Delayed_rep ! Se verdadeiro Replicador pos-posto e usado !} !} ---------------------------------------------------------------------- !{ Inicializacao de variaveis UNI=UN BTYPE=sec1%bTYPE BSUBTYPE=sec1%bsubTYPE ndxmax=sec4%nvars+100 ndesc_sec4=0 delayed_rep=.false. allocate(SEC4%d(1:sec4%nvars,1:sec3%nsubsets),STAT=ERR) allocate(desc_sec3(1:sec3%ndesc),STAT=aerr) IF(aerr>0) THEN print *,"Erro na alocacao de memoria para secao 3" stop END IF allocate(desc_sec4(1:ndxmax),STAT=aerr) IF(aerr>0) THEN print *,"Erro na alocacao de memoria para secao 3" stop END IF !} !{Expansao dos descritores: !---------------------------------------------------------------------------- ! Copia dos descritores da secao 3 e expansao dos mesmos para os ! os descritores da secao 4 !---------------------------------------------------------------------------- do auxi=1,sec3%ndesc write(auxc,'(i6.0)')sec3%d(auxi) read(auxc,'(i1,i2,i3)')desc_sec3(auxi)%f,desc_sec3(auxi)%x,desc_sec3(auxi)%y END do ndesc_sec4=0 IFinal=0 desc_sec4(:)%i=0 ! Em principio nenhum descritor e do tipo caracter call expanddesc3(desc_sec3,sec3%ndesc,ndxmax,desc_sec4,ndesc_sec4,IFinal,err) IF (err/=0) THEN print *,"Erro 53! Invalid Descriptor " stop END IF IF (IFinal/=ndesc_sec4) THEN print *,"There are Delayed Replicators in this message" delayed_rep=.true. sec3%is_cpk=0 ! Modo compactado nao e utilizado com ! replicador posposto ELSE IF(sec4%nvars/=ndesc_sec4) THEN print *,"Error! The numberes of descriptors and The numbers of variables are incompatible" print *," Expected variables = ",ndesc_sec4 print *," Provided variables = ",sec4%nvars call close_mbufr(un) stop END IF END IF IF ((sec3%is_cpk==1).and.(sec3%nsubsets<3)) THEN print *,"Aviso ! Assumindo modo nao compactado para mensagens com menos de 3 subsets" sec3%is_cpk=0 END IF !} !{ Se IdObs for fornecido entao a secao 2 e utilizada IF (present(optsec)) THEN sec2opt=.true. ELSE sec2opt=.false. END IF !} !{ Salva Secoes de 1 a 5 RG0=currentRG !Guarda o Registro da fim da mensagem anterior currentRG=RG0+8 !Salta para fim da secao 0 call savesec1(un,sec1) !{ Salva a Secao 2 se savesec2_mbufr=.true. IF (sec2opt) THEN RG2=currentRg ! Guarda a Posicao da secao2 call savesec2(un,optsec,tam_sec2) ELSE tam_sec2=0 END IF !} !{ Salva a secao 3 call savesec3(un,desc_sec3,sec3%ndesc,sec3%nsubsets,sec3%is_cpk,Tam_Sec3) IF (delayed_rep) THEN call savesec4rd(UN,desc_sec3,sec3%ndesc,sec4,sec3%nsubsets,sec4%nvars,tam_sec4) ELSE IF (sec3%is_cpk==0) THEN call savesec4(un,desc_sec4,sec4%nvars,sec4%r,sec3%nsubsets,Tam_Sec4) ELSE call savesec4cmp(un,desc_sec4,sec4%nvars,sec4%r,sec3%nsubsets,Tam_Sec4) END IF END IF call savesec5(un) !} RGF=CurrentRG ! Guarda a posicao do registro do fim da mensagem !c){ Verificacao de tamanho !------------------------------------------------------------------------------ ! Calcula o Tamanho do mensagem e verIFica se o tamanho estaao coerente com ! a posicao do registro corrente (currentRG) !------------------------------------------------------------------------------ Tam_bufr=8+18+tam_sec2+Tam_sec3+Tam_sec4+4 NRG=RGF-RG0 IF (Tam_bufr/=NRG) THEN print *, "Erro em SAVE_MBUFR" print *, "" close(un) stop END IF !} !{ GRAVACAO DA SECAO 0 ! ---------------------------------------------------------------------------- ! Grava a secao 0 da mensagem corrente e reposciona o curentRG para gravacao ! da proxima mensagem !----------------------------------------------------------------------------- currentRG=RG0 !Reposiciona registro do inicio da mensagem call savesec0(un,Tam_Bufr) !Salva a secao 0 currentRG=RGF !Reposiciona registro no fim da mensagem NMSG=NMSG+1 !Incrementa o numero de mensagens gravadas !} END SUBROUTINE WRITE_MBUFR ! ----------------------------------------------------------------------------! ! SUBROUTINE PUBLICA: MBUFR.CLOSE_MBUFR | SHSF! ! ----------------------------------------------------------------------------! ! ! ! FECHA UM ARQUIVO ABERTO POR OPEM_MBUFR ! ! ----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE CLOSE_MBUFR(UN) INTEGER,intent(in):: UN Print *," MBUFR-ADT: Number of messages=",NMSG print *," MBUFR-ADT: Size=", currentRG," Bytes" print *," MBUFR-ADT: CLOSE #",UN close (un) print *,"" END SUBROUTINE CLOSE_MBUFR ! -----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.PUT_OCTETS | SHSF ! ! -----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA PUT_OCTETS * ! * ! FUNCAO: * ! COPIA UM VETOR DE VALORES INTEIROS COM DIFERENTES NUMEROS DE BITS PARA UM * ! VETOR DE ELEMENTOS DE 8 BITS (OCTETO) * ! * ! UTILIZACAO: * ! * ! Dentro da arquitetura dos computadores,a unidade numeerica baasica e o Byte * ! de 8 bits (OCTETO), de forma que todas as variaveis armazenadas na memooria * ! ou gravados em disco, ocupam muultiplos de bytes (8bits). * ! * ! Uma das formas de REALizar compactacao da informacao em disco, comsiste no * ! reaproveitamento dos bits de uma variaavel, para guadar outras. EE o caso * ! do formato BUFR, que utiliza esta teecnica largamente * ! * ! Esta subrotina permite que este reaproveitamento seja feito utilizando a * ! seguinte estrutura * ! * ! A_VAL(NA) --> Vetor Inteiro com os NA dados de entrada * ! A_BITS(NA)--> Vetor Inteiro com o numero de BITS, que deseja-seutilizar * ! para gravar cada elemento de A_VAL * ! NA --> Nuumeor de elementos de A_VAL A_BITS * ! * ! OCT(NOCT) <-- Vetor Caracter (de 1 Byte (OCTETO) * ! NOCT <-- Nuumero de Elementos de OCT * ! ERR <-- Zero se a coopia foi bem sucedida * ! Utilizando esta estrutura cada elemento de A_VAL ee copiado Bit-a-Bit para * ! OCT, de forma aa sempre completar os oito bits de OCT.Os bits que naao * ! cabem em OCT, sao copiados para o prooximo elemento de OCT, de forma que * ! todos os elementos de OCT teraao seus bits completados, com excessaap do * ! uultimo OCT. Este poderaa, eventualmente ter seus bits incompletos. * ! Neste caso, err retornaraa o numero de bits faltantes no uultimo octeto * ! * ! IMPORTANTE. * ! * ! 1- Certifique-se que o Ultimo OCT tenha bits completos, fornecendo * ! sempre um conjunto de A_VAL, cuja soma dos bits de todos os * ! elementos sejam multiplos de 8 * ! * ! 2- Esta rotina esta preparada para copiar elementos de A_VAl que nao * ! exceda o tamanho de 64 bits. No caso deste tamanho ser excedido * ! poderaao ocorrer erro de DIMENSIONamento da matriz local BIT * ! * ! 3- Esta rotina, pressupoe que os bits fornecidos em A_BITS(:), sao * ! realmente suficientes para guardar os valores A_VAL(:). Caso seja * ! insuficiente, os bits mais signIFicativos seraao cortados. * ! Esta e uma parte que precisa ser melhorada. Poderia ser colocado * ! algum teste para verificar e enviar uma mensagem de erro! * ! * ! * ! EXEMPLO: * ! Neste Exemplo sao fornecidos 5 Valores A_VAL, cada um com res- * ! pectivamente 14, 3, 7, 5 e 4 bits. Neste exemplo esta rotina * ! retorna 5 octetos (OCT), que contem os bits de A_VAL redistri- * ! buidos conforme o esquema abaixo * ! * ! A_VAL 11111111111111 000 1010101 00000 1111--+ * ! \---+--/\---+---/\----+---/ \----+---/ | * ! | | | | | * ! +------+ +------+ +------+ +------+ | * ! | | | | | | | | | * ! OCT 11111111 11111100 01010101 00000111 10000000 * ! * ! * ! Neste caso, os 5 Elementos de A_VAL sao copiados em 5 octetos * ! Contudo no Octeto 5, somente 1 bit e utilizado. Os demais 7bits * ! ficam com zero. Por isto, neste caso e retornado err=7 * ! * ! * !******************************************************************************* ! -----------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! -----------------------------------------------------------------------------! SUBROUTINE PUT_OCTETS(A_VAL,A_BITS,NA,OCT,NOCt,err) !{ Variaveis da Interface INTEGER,DIMENSION(:),intent(inout)::A_VAL ! Conjunto de valores de entrada com bits dIFerentes INTEGER,DIMENSION(:),intent(in)::A_BITS ! Vetor com o numero de bits do conjunto A_VAL INTEGER,intent(in)::NA ! Numero de elementos de A_VAL e A_BITS CHARACTER(len=1),DIMENSION(:),intent(out)::OCT ! Vetor caractere com octetos de saida INTEGER,INTENT(OUT)::nOCT ! Numero de elementos de OCT INTEGER,INTENT(OUT)::err ! Indica se o ultmo octeto foi completado corretamente. ! err = 0 :Todos os bits foram completados ! err de 1 a 7 :Numero de bits que faltaram !} !{ Variaveis locais INTEGER,DIMENSION(8,NA*10)::BIT ! Array auxiliar para redistribuicao de bits INTEGER:: k,j,i,n,valmax INTEGER::V CHARACTER(len=1)::aux !} !{ redistribuir os bits da variavel A_VAL em octetos (Vetor BIT) K=0 j=1 BIT(1:8,J)=0 ! Zera os bits do primeiro octeto DO N=1,NA !{VerIFicar se o numero de bits estao dentro do esperado IF (A_BITS(n)>64) THEN PRINT *,"Erro em"//TRIM(SUBNAME)//"_copy2oct !" PRINT *, "Possivel erro na especificacao do tamanho da variavel ",N print *, "Numero de bits=",A_BITS(n) stop END IF !} !VerIFicar se o valor fornecido ee compatiivel com !o nuumero de bits fornecidos ou se ee valor missing !{ valmax=vmax_numbits(A_BITS(n)) IF (A_VAL(n)==null) A_VAL(n)=valmax IF (((A_VAL(n)<0).or.(A_VAL(n)>valmax)).and.valmax>0) THEN IF (index(SUBNAME,"SAVESEC4")>0) THEN A_VAL(n)=valmax ! print *," Substituido por valor missing" ! print *,"" ELSE PRINT *,"Erro em "//TRIM(SUBNAME)//"_put_octets !" write(*,500)N,A_VAL(n) 500 FORMAT( " Variavel(",I6.6,") =",I11) STOP ENDIF END IF DO I=1,A_BITS(N) K=K+1 IF (K>8) THEN J=J+1;K=1 BIT(1:8,J)=0 ! Zera os bits para armazenar o proximo octeto END IF BIT(9-K,J)=IBITS(A_VAL(N),A_BITS(N)-i,1) END DO END DO !} Fim da redistribuicao NOCT=J !{ Converter os octetos BIT para valores decimal(V) e para variavel string (oct) do j=1,noct v = 0 do i = 1,8 v = BIT(I,J)*2 ** (i-1) + v ! END do aux=char(v) oct(j)=aux END do !} Fim da conversao para string !err=0 Indica que o ultimo octeto foi completado corretamente ! caso contrario, err indica o numero de bits que faltarem para ! completar o ultimo octeto !{ err=8-k !} END SUBROUTINE PUT_OCTETS ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.SAVESEC0 | SHSF! ! ----------------------------------------------------------------------------! ! ! ! Esta Subrotina grava a Secao 0 de uma mensagem BUFR ! ! ! As Variaveis de entrada sao ! UN Unidade Logica de Gravacao ! Tam_BUFR Tamanho da Mensagem ! ! ! Nesta secao sao gravados as seguintes informacoes: ! a) A palabra "BUFR" nos 4 primeiros Bytes ! b) A Variavel Tam_BUFR com 3 Bytes ! c) O Numero da edicao do codigo BUFR (1Byte) ! ! Obsercoes ! ! 1 - Note que Tam_BUFR poderia assumir valores de atee 16777213 , que ee o maior ! inteiro positivo com 24 bits. Contudo, por convencao, uma mensagem ! BUFR podera ter no maximo 10000 Bytes. Desta forma, esta sub-rotina ! imprime na tela um aviso quando for ultrapassado o limite de 10000. ! No caso de tentativa de gravar uma mensagem BUFR acima de 16777213 uma ! mensagem de erro e mostrado e a gravacao e cancelada ! ! 2 - Variaveis internas Importantes ! A() E um vetor de valores inteiros de 4 bytes ! B() E um vetor de numero de bits utilizados para representar cada ! valor de A() ! sec0() E o vetor CHARACTER que armazena os octetos para gravacao da ! secao 0. Este vetor ee obtido a partir da copia sequencial ! bit-a-bit de cada valor de A(), atraves da sub-rotina copy2oct !-----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:PUT_OCTETS ! ! ----------------------------------------------------------------------------! SUBROUTINE SAVESEC0(UN,Tam_BUFR) INTEGER, intent(in)::UN ! Unidade loogica INTEGER, intent(in)::Tam_BUFR ! Tamanho da mensagem BUFR !{Variaveis Internas CHARACTER(len=1),DIMENSION(8)::sec0 ! Vetor de octetos (1byte) INTEGER :: uni,err,noct,i ! Outras Variaveis Auxiliares INTEGER,DIMENSION(6)::A,B ! Vetor de Valores Inteiros 4 bytes a ser convertidos !} uni=un SUBNAME="SAVESEC0" ! Para fins de controle de erros !{ Verifica erro no tamanho da mensagem IF (Tam_BUFR > 16777213) THEN print *, "Erro em MBUFR"//SUBNAME print *, "Mensagem muito grande. Tamanho= ", Tam_BUFR print *, "Numero do Mensagem =",NMSG print *, "" close(uni) stop END IF IF (Tam_BUFR > 10000 ) THEN print *," Aviso ! Tamanho da Mensagem excedeu limite de 10KBytes " print *," Mensagem =", NMSG print *," Tamanho = ", Tam_BUFR print *,"" END IF !} !{ Prepara para gravar secao 0 B(1)= 8;A(1)=ichar("B") B(2)= 8;A(2)=ichar("U") B(3)= 8;A(3)=ichar("F") B(4)= 8;A(4)=ichar("R") B(5)=24;A(5)=Tam_BUFR ! Tamanho total do arquivo B(6)= 8;A(6)=BUFR_EDITION ! BUFR edicao = 3 OU 4 !{Organiza os dados da secao 0 em octetos (sec0) ! Neste caso o numero de octeros noct tem que ser sempre 8 call PUT_OCTETS(A,B,6,sec0,noct,err) IF ((noct/=8).or.(err/=0)) THEN print *,"Erro na especificacao da secao 0 : numero de octetos =",noct print *,"" close(uni) stop END IF !} !{Inverte a ordem dos octetos 5,6 e 7 para 7,6 e 5 !} !{ Grava a secao 0 do i=1,8 currentRG=currentRG+1 write (uni,rec=currentRG) sec0(i) END do !} END SUBROUTINE SAVESEC0 ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.SAVESEC1 | SHSF! ! ----------------------------------------------------------------------------! ! ! ! DEFINE E GRAVA A SECAO 1 ! ! ----------------------------------------------------------------------------! ! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:PUT_OCTETS ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE SAVESEC1(UN,sec1e) INTEGER, intent(in)::UN TYPE(sec1TYPE),intent(in)::sec1e CHARACTER(len=1),DIMENSION(18):: sec1 ! Para gravar os 18 bytes da secao 1 INTEGER :: uni,noct,err,I INTEGER,DIMENSION(16)::A,B ! Vetor de Valores e Numero de bits de cada valor uni=un SUBNAME="SAVESEC1" B(1)=24; A(1)=18 !-Contem o tamanho da secao 1 (Bytes de 1 a 3) que E sempre 18 ? B(2)=8 ; A(2)=0 !-Contem a versao da BUFR master table (Byte 4) ! Para meteorologia=0. B(3)=16; A(3)=sec1e%center !-Contem o codigo do centro que gerou o arquivo BUFR, ! segundo a code table 0 01 031 (ver manual WMO). ! No caso, o codigo do INPE (Brazilian Space Agency !?) ! eh 46 (Bytes de 5 a 6) B(4)=8; A(4)=1 !-Update sequence number = 0 (=1 a pedido da Elizabet) (byte 7) IF (sec1e%sec2present) THEN B(5)=1; A(5)=1 !-Se este bit=0 entao nao ha sessao 2 (byte 8, bit 0) ELSE B(5)=1; A(5)=0 END IF B(6)=7; A(6)=0 ! Estes bits sao reservados (byte 8, bits de 1 a 7) B(7)=8; A(7)=sec1e%bTYPE !-Data category TYPE (BUFR Table A) (Byte 9) ! Exemplo: 0 = surface data/land B(8)=8; A(8)=sec1e%bsubTYPE !-Data category sub-TYPE ! DepENDe do centro gerador B(9)=8; A(9)=VerMasterTab !-Versao utilizada da tabela Master/WMO (Byte 11) B(10)=8; A(10)=VerLocTab !-Versao utilizada da tabela local/INPE (Byte 12) ! Um detalhe importante nos proximos bytes (13-18), e o fato de que centro dIFe- ! rentes estao usando padroes dIFerentes aqui !!! - A ordem a seguir eh a reco - ! mENDada pela WMO, mas o NCEP, por exemplo, poe o ano nos bytes 13 e 14, fazen- ! do um shIFt nos demais dados e o minuto no byte 18. ! Devido a estas dIFerencas, uma boa politica pode ser: nao usar a data que es - ! tiver nesta secao, ou decodIFicar de acordo com o centro que gerou a mensagem. ! Ano do Seculo (Byte 13) B(11)=8 IF (sec1e%year<=2000) THEN A(11)= sec1e%year - 1900 ELSE A(11)=sec1e%year - 2000 END IF B(12)=8; A(12)= sec1e%month ! Mes da Observacao (Byte 14) B(13)=8; A(13)= sec1e%day ! Dia da Observacao (Byte 15) B(14)=8; A(14)= sec1e%hour ! Hora da Observacao (Byte 16) B(15)=8; A(15)= sec1e%minute ! Minuto da Observacao (Byte 17) B(16)=8; A(16)= 0 ! Reservado para uso local - (Byte 18) ! Organiza os dados da secao 1 em octetos (sec1) ! Neste caso o numero de octeros noct tem que ser sempre 18 !{ call PUT_OCTETS(A,B,16,sec1,noct,err) IF ((noct/=18).or.(err/=0)) THEN print *,"Erro na especificacao da secao 1 : numero de octetos =",noct stop END IF !} !Grava os 18 byte da secao 1 (SHSF) !{ do i=1,18 currentRG=currentRG+1 write (uni,rec=currentRG) sec1(i) END do !} END SUBROUTINE SAVESEC1 ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.SAVESEC2 | SHSF! ! ----------------------------------------------------------------------------! ! ! ! GRAVA A SECAO 2 ! ! ----------------------------------------------------------------------------! ! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:PUT_OCTETS ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE SAVESEC2(UN,sec2,tam_sec2) !{ Variaveis da Interface INTEGER, intent(in)::UN TYPE(sec2TYPE),intent(in)::sec2 ! Dados secao 2 INTEGER,intent(out)::tam_sec2 ! Tamanho secao 2 !} !{ Variaveis Locais INTEGER,DIMENSION(2)::A,B ! Vetor de Valores e Numero de bits de cada valor CHARACTER(LEN=1),DIMENSION(4)::sec2cab ! Cabecalho secao 2 INTEGER :: noct, i, uni,err !} SUBNAME="SAVESEC2" uni=un tam_sec2=sec2%nocts+4 !{ Gravando cabecalho da secao 2 B(1)=24; A(1)=tam_sec2 !-Contem o tamanho da secao 2 (Bytes de 1 a 3) que E sempre 18 ? B(2)=8 ; A(2)=0 !-Contem a versao da BUFR master table (Byte 4) call PUT_OCTETS(A,B,2,sec2cab,noct,err) if (err>0) then print *,"Erro na gravacao da secao 2" stop end if do i=1,noct currentRG=currentRG+1 write (uni,rec=currentRG) sec2cab(i) END do !} !{ Gravando o restante da secao 2 do i=noct+1,tam_sec2 currentRG=currentRG+1 write (uni,rec=currentRG) sec2%oct(i-noct) END do !} !{ A secao tem que ter numero par. if (mod(tam_sec2,2)/=0) then currentRG=currentRG+1 write (uni,rec=currentRG) char(0) end if END SUBROUTINE SAVESEC2 ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.SAVESEC3 | SHSF ! ! ----------------------------------------------------------------------------! ! ! ! DEFINE E GRAVA A SECAO 3: ! ! Esta secao possui tamanho variado: Os 7 primeiros bytes sao fixos ! e permite identificar as caracteristicas da secao. Os demais armazenam os ! descritores. Cada descritor ocupam 2 bytes ! ----------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:PUT_OCTETS ! ! ----------------------------------------------------------------------------! SUBROUTINE SAVESEC3(UN,D,Ndesc,NSUBSET,is_cmp,tam_sec3) !{ Variaveis da Interface INTEGER, intent(in)::UN TYPE(descbufr),DIMENSION(:),intent(in)::D ! Descritores BUFR INTEGER,intent(in)::Ndesc ! Numero de descritores INTEGER,intent(in)::Nsubset ! Numero de subsecoes INTEGER,intent(in)::is_cmp ! Indica se eum bufr compactador 0=nao compactado INTEGER,intent(inout)::tam_sec3 ! tamanho da secao 3 !} !{ Variaveis locais CHARACTER(len=1),DIMENSION (2000):: sec3 INTEGER,DIMENSION(8000)::A,B ! Vetores de Valores e Numero de bits INTEGER :: uni ,ib ,i,err,noct,xx !} uni=un SUBNAME="SAVESEC3" !------------------------------------------------------------------- ! Obs.: AUTO-TESTE DE GRAVACAO DA SECAO 3 ! ! Esta secao devera ter tamanho (Tam_sec3) igual a: ! 7 Bytes que descrevem a secao + ! 2 vezes o Numero de descritores das variaveis ! ! Ao final desta sub-rotina e feito uma verificao deste tamanho. ! Caso seja verificado tamanhos diferentes, uma mensagem de erro ! seraa apresentada na tela e o programa interrompido !------------------------------------------------------------------- Tam_sec3 = 7+2*(Ndesc) IF (mod(Tam_sec3,2)>0 ) Tam_sec3=Tam_sec3+1 B(1)=24;A(1)=Tam_sec3 ! Tamanho da Secao (bites de 1-3) b(2)=8;a(2)=0 ! byte reservado (bite 4) b(3)=16;a(3)=Nsubset ! Numero de data subsets (observacoes em cada registro BUFR) byte b(4)=1;a(4)=1 ! se 1 Indica dados observacionais b(5)=1;a(5)=is_cmp ! se 1 Indica dados comprimidos b(6)=6;a(6)=0 ! Demais bits do octeto saao 0 (byte 7) !A partir do byte 8, comeca a gravacao dos descritores ib=6 do i=1,Ndesc ib=ib+1;b(ib)=2;a(ib)=D(I)%F ib=ib+1;b(ib)=6;a(ib)=D(I)%X ib=ib+1;b(ib)=8;a(ib)=D(i)%Y END do !{ Organiza os dados da secao 3 em octetos (sec3) call PUT_OCTETS(A,B,ib,sec3,noct,err) ! Se o numero de octetos naao for par ! acrescentar um octeto com zero !{ IF (mod(noct,2)>0) THEN noct=noct +1 sec3(noct)=char(0) END IF !} IF ((err/=0).or.(noct/=Tam_sec3)) THEN print *,"Erro no tamanho da secao 3 : numero de octetos =",NOCT stop END IF !} xx=ichar(sec3(7)) !} Fim da preparacao para gravacao da secao 3 !{ Gravar do i=1,noct currentRG=currentRG+1 write (uni,rec=currentRG) sec3(i) END do !} !} Fim da Gravacao da secao 3 END SUBROUTINE SAVESEC3 ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.SAVESEC4 | SHSF! ! ----------------------------------------------------------------------------! ! ! ! DEFINE E GRAVA A SECAO 4 no caso simples (Sem replicadores pos-postos e ! ! e sem compactacao) ! ! ----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:PUT_OCTETS, TABC_SETPARM,CINT, BITS_TABB2, ! ! ----------------------------------------------------------------------------! SUBROUTINE SAVESEC4(UN,D,ndesc,v,nsubset,tam_sec4) TYPE(descbufr),DIMENSION(:),intent(in)::D ! Descritores BUFR INTEGER, intent(in)::UN ! INTEGER,intent(in)::ndesc ! Numero de descritores REAL,DIMENSION(:,:)::v INTEGER,intent(out)::tam_sec4 INTEGER,intent(in)::nsubset INTEGER,DIMENSION((nsubset*(ndesc+5)*4))::A,B ! Vetor de Valores e Numero de bits de cada valor CHARACTER(len=1),DIMENSION((nsubset*ndesc+5)*16):: sec4 ! Valor anterior e 28 CHARACTER(len=1),DIMENSION(4)::auxsec4 INTEGER :: uni ,k,err,noct,noctaux ,j ,i,dimab,dimoct uni=un SUBNAME="SAVESEC4" dimab=(nsubset*(ndesc+5)*4) ! Calculo da dimensao de B() e A() dimoct=dimab*8 ! Estimativa do nuumero de octetos b(1)=24;a(1)=0 ! Tamanho da secao 4 Ainda naao ee conhecido b(2)=8; a(2)=0 ! byte reservado (= 0) k=2 ! Prepara para gravar todos os subsets (Valors e Indices de confiabilidade) ! { do i=1,nsubset call tabc_setparm(err=err) !Valores !{ do j=1, ndesc IF (d(j)%f==0) THEN k=k+1 b(k)=bits_tabb2(d(j)) a(k)=CINT(v(j,i),d(J)) END IF END do !} END do ! Organiza os dados da secao 4 em octetos (sec4) ! Neste caso o numero de octeros noct tem que ser sempre 52 !{ call PUT_OCTETS(A,B,k,sec4,noct,err) ! Se o nuumero de octetos (Secao3+secao4)naao for par ! acrescentar um octeto com zero ! { IF (mod(noct,2)>0) THEN noct=noct +1 sec4(noct)=char(0) END IF !} !} ! Agora coloca o tamanho da secao 4 Tam_Sec4=noct B(1)=24;a(1)=Tam_Sec4 call PUT_OCTETS(A,B,1,auxsec4,noctaux,err) IF ((noctaux/=3).or.(err/=0)) THEN print *,"erro secao 4 " stop END IF sec4(3)=auxsec4(3) sec4(2)=auxsec4(2) sec4(1)=auxsec4(1) !} Fim da preparacao para gravacao da secao 4 !{ Gravar do i=1,noct currentRG=currentRG+1 write (uni,rec=currentRG) sec4(i) END do !} !} Fim da Gravacao da secao 4 END SUBROUTINE SAVESEC4 ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.SAVESEC4RD | SHSF! ! ----------------------------------------------------------------------------! ! ! ! DEFINE E GRAVA A SECAO 4 com o uso do replicador pos-posto (delayed repl) ! ! e sem compactacao) ! A diferenca desta gravacao para a gravacao normal requer que ! as estruturas sec3 e sec4 entrem dentro da subrotina diretamente ! A expansao dos descritores ocorrem aqui dentro ! ! ----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:PUT_OCTETS, TABC_SETPARM,CINT, BITS_TABB2, ! ! ----------------------------------------------------------------------------! SUBROUTINE SAVESEC4RD(UN,desc_sec3,ndesc_sec3,sec4e,nsubset,nvarmax,tam_sec4) !{ Variaveis da interface INTEGER, intent(in)::UN TYPE(descbufr),pointer,DIMENSION(:)::desc_sec3 ! Descritores da secao3 INTEGER,intent(in)::ndesc_sec3 ! Numero de descritores da secao 3 TYPE(sec4TYPE),intent(in)::sec4e ! Secao 4 INTEGER,intent(in)::nsubset ! Numero de subsecoes INTEGER,intent(in)::nvarmax ! Numero maximo de variaveis INTEGER,intent(out)::tam_sec4 ! Tamanho da secao 4 apos gravacao !} !{ Variaveis locais INTEGER::ndesc_sec4 ! Numero de descritores INTEGER::IFinal ! Variavel auxiliar para expanddesc INTEGER:: fatorR ! Fator de Replicacao TYPE(descbufr),pointer,DIMENSION(:)::d TYPE(descbufr)::auxdesc ! Variavel auxiliar para descritores INTEGER,DIMENSION((nsubset*(nvarmax+5)*4))::A,B ! Vetor de Valores e Numero de bits de cada valor CHARACTER(len=1),DIMENSION((nsubset*nvarmax+5)*16):: sec4 CHARACTER(len=1),DIMENSION(4)::auxsec4 INTEGER :: uni,k,err,noct,noctaux,j,i !} uni=un SUBNAME="SAVESEC4RD" allocate(D(1:nvarmax),STAT=err) IF(err>0) THEN print *,"Erro na alocacao de memoria para secao 3" stop END IF b(1)=24;a(1)=0 ! Tamanho da secao 4 Ainda naao ee conhecido b(2)=8; a(2)=0 ! byte reservado (= 0) k=2 ! Prepara para gravar todos os subsets (Valors e Indices de confiabilidade) ! Como o numero de variaveis pode "variar" em cada subset de ! informacao, uma nova expansao de descritores precisa ser feita ! para cada subset ! ! Note que o numero de descritores da secao 3 nao muda. Ele e fixo ! o que muda sao os descritores expandidos para a secao 4, que ! podem ser dIFerentes `a cada subsecao de informacao ! ! Um outro problema `e o numero maximo de variaveis (nvarmax) ! esse nao indica de fato o numero de valores na secao 4 de ! um subset especIFico e sim do maior subset. O problema em ! questao `e como deteminiar o fim da expansao dos descritores ! ! { do i=1,nsubset IFinal=0 20 call expanddesc3(desc_sec3,ndesc_sec3,nvarmax,D,ndesc_sec4,IFinal,err) IF (IFinal0) goto 77 ! Nao comprimir variaveis caracter vmaxbits=vmax_numbits(nbits) vmin=vmaxbits vmax=0 do i=1,nsubset IF (v(j,i)/=null) THEN vint= CINT(v(j,i),D(J)) IF ((vint>=0).and.(vintvmax) vmax=vint END IF END IF END do nbits=numbits_vint(vmax-vmin) ! Numero de bits comprimidos !} 77 continue !{ Codificar elemento !{Valor minimo k=k+1 b(k)=bits_tabb2(d(j)) a(k)=vmin !} !{ Numero de bits para gravar as dIFerenca k=k+1 b(k)=6 a(k)=nbits !} !{ Gravar as diferencas (Dados comprimidos IF (nbits>0) THEN do i=1,nsubset k=k+1 b(k)=nbits vint=CINT(v(j,i),D(J)) IF ((vint>=vmin).and.(vint0) THEN noct=noct +1 sec4(noct)=char(0) END IF !} !} ! Agora coloca o tamanho da secao 4 Tam_Sec4=noct B(1)=24;a(1)=Tam_Sec4 call PUT_OCTETS(A,B,1,auxsec4,noctaux,err) IF ((noctaux/=3).or.(err/=0)) THEN print *,"erro secao 4 " stop END IF sec4(3)=auxsec4(3) sec4(2)=auxsec4(2) sec4(1)=auxsec4(1) !} Fim da preparacao para gravacao da secao 4 !{ Gravar do i=1,noct currentRG=currentRG+1 write (uni,rec=currentRG) sec4(i) END do !} !} Fim da Gravacao da secao 4 END SUBROUTINE SAVESEC4CMP ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.SAVESEC5 | SHSF! ! ----------------------------------------------------------------------------! ! ! ! GRAVA A SECAO 5 (7777) ! ! ! ! ----------------------------------------------------------------------------! ! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE SAVESEC5(UN) !{ Variaveis de interface INTEGER, intent(in)::UN !} !{ Variaveis locais INTEGER :: uni INTEGER :: i CHARACTER(len=1),DIMENSION(4)::sec5 !} !{ Grava "7777" sec5(1:4) = '7' uni=un do i=1,4 currentRg=currentRG+1 write (uni,rec=currentRG) sec5(i) END do END SUBROUTINE SAVESEC5 ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.INIT_TABB | SHSF! ! ----------------------------------------------------------------------------! ! ! ! INICIALIZA A TABELA BUFR B ! ! LER A TABELA B E CARREGANDO OS VALORES NA MATRIZ GLOBAL TABB ! ! ----------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! SUBROUTINE INIT_TABB(Un) !{ Variaveis de interface INTEGER,intent(in)::Un ! Unidade para a leitura da tabela BUFR B !} !{ Variaveis locais INTEGER::uni ,i INTEGER::F,X,Y,SCALE,REFV,NBITS CHARACTER(len=255)::C4,C5 CHARACTER(len=255)::A CHARACTER(len=255)::filename !} !{ Inicializando variaveis e nome do arquivo da tabela uni=un i=0 TABB(:,:,:)%scale=0 TABB(:,:,:)%refv=0 TABB(:,:,:)%nbits=0 TABB(:,:,:)%u=0 write(filename,14)centre_mbufr,VerMasterTab,VerLocTab 14 format("B000",i3.3,2i2.2,".txt") filename=trim(local_tables)//filename !} !{ CARREGANDO TABELA BUFR B print *," Table B -> ",trim(filename) OPEN (UNI, FILE =filename, ACCESS = 'SEQUENTIAL', STATUS = 'OLD') 10 READ(UNI,"(A)",END=999)A IF (len_trim(a)>10) THEN READ(A,100)F,X,Y,C4,C5,SCALE,REFV,NBITS 100 FORMAT(1X,I1,I2,I3,1X,A64,1X,A22,1X,I5,1X,I12,1X,I3) IF ((F==0).and.(x<=35).and.(x>=0).and.(y<=256).and.(y>=0)) THEN IF (NBITS>256) THEN print *,"Erro na leitura da tabela bufr" print *,"Linha=",I,"Nbits=",NBITS close (uni) stop END IF TABB(F,X,Y)%scale=SCALE TABB(F,X,Y)%refv=REFV TABB(F,X,Y)%nbits=NBITS TABB(F,X,Y)%u=0 IF (INDEX(C5,"CCITTIA5")>0) TABB(F,X,Y)%u=1 IF (INDEX(C5,"FLAG")>0) TABB(F,X,Y)%u=2 IF (INDEX(C5,"CODE")>0) TABB(F,X,Y)%u=3 END IF END IF i=i+1 GOTO 10 999 CLOSE(UNI) END SUBROUTINE INIT_TABB ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.INIT_TABD | SHSF! ! ----------------------------------------------------------------------------! ! ! ! INICIALIZA DESCRITORES DA TABELA BUFR D ! ! LER A TABELA D EXPANDIDA CARREGANDO OS VALORES NA MATRIZ GLOBAL TABD ! ! ! ! A tabela D padrao (.txt) corresponde a uma tabela de descritores em que ! ! cada chave (ou descritore da tabela D) aponta para um conjunto de outros ! ! descritores. ! ! Este conjunto pode conter: ! ! ! ! a) Outros descritores da tabela D ! ! b) Descritores da tabela B ! ! c) Descritores da tabala C ! ! d) Descritores replicadores ! ! e) Descritores replicadores pos-postos ! ! ! ! A tabela D Expandida (.ext), necessaria nesta rotina, ee obtida a ! ! partir da varredura recursiva da tabelas D original (.txt) de forma a ! ! sere expandidos todos os subniveis de descritores da tabela D e feita ! ! as devidas compensacoes nos descritores replicadores e replicadores ! ! pos-postos ! ! !* O arquivo .ext contem as seguintes !* informacoes : !* !* nl l F X Y Fl Xl Yl !* !* onde : !* nl = Numero de linhas que contem os dados de !* cada descritor da tabela D !* l = Numero da linha (1:nl) !* !* F X Y = Descritores da tabela D !* Fl Xl Yl = Conjunto de nl descritores das demais tabelas !* que corespondem aos descritores da tabela D !* (Descritores expandidos) !* ! ! ----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! ! ! 2007-01-18 - SHSF: Elimizado o zeramento de TABD. E' suficiente ! zarar o NDTABD, QUE CONTEM O NUMERO de DESCRITORES DE TABD ! , PARA QUE A SUBROTINA EXPANDESCD POSSA DISTINGUIR ! UM DESCRITOR INESISTENTE NA TABELA D !_____________________________________________________________________________! SUBROUTINE INIT_TABD(Un) INTEGER,intent(in)::Un !Unidade de leitura do arquivo !{Declaracao de variaveis auxiliares INTEGER::uni INTEGER ::nl,l,f,x,y,f2,x2,y2,i,f1,x1,y1,nl1 CHARACTER(len=255)::filename CHARACTER(len=255)::linha character(len=1)::t1 !} uni=un i=0 write(filename,18)centre_mbufr,VerMasterTab,VerLocTab 18 format("D000",i3.3,2i2.2".ext") !{Zerando variaveis NDTABD(:,:,:)=0 !} filename=trim(local_tables)//filename Print *," Table D -> ",trim(filename) OPEN (UNI, FILE =filename, ACCESS = 'SEQUENTIAL', STATUS = 'OLD') 888 READ(UNI,'(a)',END=9898)linha read(linha,'(1x,i1,i2,i3,1x,i3,a1,i1,i2,i3)')f1,x1,y1,nl1,t1,F2,X2,Y2 if (t1/="") then read(linha,'(1x,i1,i2,i3,1x,i2,a1,i1,i2,i3)')f1,x1,y1,nl1,t1,F2,X2,Y2 end if IF (nl1>0) THEN f=f1 x=x1 y=y1 l=0 nl=nl1 END IF l=l+1 TABD(F,X,Y,l)%F=F2 TABD(F,X,Y,l)%X=X2 TABD(F,X,Y,l)%Y=Y2 NDTABD(F,X,Y)=nl i=i+1 goto 888 9898 continue END SUBROUTINE INIT_TABD ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.REINITTABLES | SHSF! ! ----------------------------------------------------------------------------! ! Reinicializa leitura das tabelas BUFR, para vers�s das tabelas ! dIFerENDete das vers�s especIFicadas em OPEN_MBUFR ! ! ! ! ----------------------------------------------------------------------------! ! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:INIT_TABB,INIT_TABD ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE REINITTABLES(Center,MasterTable,LocalTable,Err) !{ Variaveis de interface INTEGER,intent(in) :: center INTEGER, intent(in) :: MasterTable INTEGER,intent(in):: localTable INTEGER, intent(out) :: err !} !{ Variaveis locais CHARACTER(len=255):: tabb_filename,tabd_filename LOGICAL :: exists !} write(tabb_filename,14)center,MasterTable,LocalTable 14 format("B000",i3.3,2i2.2,".txt") write(tabd_filename,15)center,MasterTable,LocalTable 15 format("D000",i3.3,2i2.2,".ext") tabb_filename=trim(local_tables)//tabb_filename tabd_filename=trim(local_tables)//tabd_filename INQUIRE (FILE = tabb_filename, EXIST = exists) IF (exists) inquire(file=tabd_filename, EXIST=exists) IF (exists) THEN centre_mbufr=center VerMasterTab=MasterTable VerLocTab=localtable call INIT_TABB(99) call INIT_TABD(99) err=0 ELSE err=1 END IF END SUBROUTINE REINITTABLES !------------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.GET_OCTETS | SHSF ! ! -----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA GET_OCTETS * ! * ! FUNCAO: * ! COPIA UM VETOR DE ELEVEMTOS DE 8 BITS (OCTETO) PARA VETOR DE VALORES * ! INTEIROS COM DIFERENTES NUMEROS DE BITS * ! * ! NOTA: * ! * ! Processo inverso da rotina PUT_OCTETS - Para mais detalhes vide PUT_OCTETS * ! -----------------------------------------------------------------------------! ! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! -----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !______________________________________________________________________________! SUBROUTINE GET_OCTETS(oct, noct, A_BITS, A_VAL, NA,APOS, ERR) !{ Variaveis da interface CHARACTER(len=1),DIMENSION(:), intent(in):: oct !Vetor de octetos INTEGER,intent(in):: noct !' Numero de octetos em oct INTEGER,DIMENSION(:),intent(in)::A_BITS !'Vetor de numeros de bits para cada variavel !' que se deseja obter INTEGER,intent(in):: NA ! NA = Numero elementos de A_BITS ou A_VAL INTEGER,intent(in)::APOS ! Se maior que zero inidica um salto para ! uma posicao de A_VAL, apos a qual receberar ! os valores recortados de OCT ! A posicao de OCT tambem e localizada, assim como ! o Bit exato onde comeca a conversao de OCT para A_VAl INTEGER,DIMENSION(:), intent(out)::A_VAL !' Vetor com os valores extraidos de oct. !' A_BITS(i)= Numero de Bits de A_VAL(i) INTEGER,intent(out):: err !'retorna valor que indica se houve discrepancias !' Entre o tamanho de oct e o total de bits solicitados ! Err >0 indica que existem mais bits em OCT do que o solicitado em A_BITS ! Err = 0 indica que o numero de bits existentes em oct é exatamente o solicitado em A_BITS ! Err < 0 indica que naao existem bits suficientes em OCT para atENDer a solicitacao em A_BITS. ! Neste ultimo caso, um erro ee apresentado na tela !} !{ Variaveis locais e auxiliares INTEGER,DIMENSION(8,noct):: bit(8, noct) ! Array auxiliar para redistribuicao de bits INTEGER :: i, J, sbits, k, b INTEGER :: BYTEINI,BITINI INTEGER ::NOCT2 INTEGER :: conta1 !} !{ Inicializacao de variaveis SBITS=0 !} !{Calcula o numero de octetos que serao decodificados e determin o err do k = 1, NA sbits = sbits + A_BITS(k) END do ERR = (noct * 8 - sbits) IF (ERR < 0) THEN !print *,"Erro "//TRIM(SUBNAME)//"_GET_OCTETS : Tentativa de ler um numero de bytes maior do que os fornecidos" return ELSEIF (ERR>0) THEN NOCT2=SBITS/8+1 ELSE NOCT2=NOCT END IF !} !{ OBTEM O PRIMEIRO OCTERO QUE SERA UTILADO, ASSIM COMO O PRIMEIRO ! bite deste octero que sera lido BYTEINI=1 BITINI=0 IF (APOS>0) THEN SBITS=0 do k = 1,APOS sbits = sbits + A_BITS(k) END do BYTEINI=sbits/8 +1 BITINI=sbits-(BYTEINI-1)*8 END IF !{Converte os octetos de entrada para matriz boleana auxilar do i = BYTEINI, noct2 do J = 0, 7 bit(8 - J, i) = ibits(ichar(oct(i)), J, 1) END do END do !'} !'{ Agora vamos fazer a redistribuicao i = BYTEINI J = BITINI+1 do k = (APOS+1), NA A_VAL(k) = 0 IF (A_BITS(K)>0) THEN conta1=0 do b = 1,A_BITS(k) !' Varia do bit1 ao numero de bits de A_VAL(k) IF (i > noct2) THEN print *,"Erro "//TRIM(SUBNAME)//"_GET_OCTETS : Numero de bits Inesperado e insuficientes" err=noct2-i return END IF IF (bit(j,i)==1) conta1=conta1+1 A_VAL(k) = A_VAL(k) + bit(J, i) * 2 ** (A_BITS(k) - b) J = J + 1 IF (J > 8) THEN J = 1 i = i + 1 END IF END do !{ VALORES MISSING SO SAO ATRIBUIDOS A VARIAVEIS DA SECAO 4 ! QUE TENHA PELO MENOS 2 BITS IF ((conta1==A_BITS(K)).AND.(INDEX(SUBNAME,"READSEC4")>0)) THEN IF (A_BITS(K)>1) A_VAL(K)=NULL END IF !} ELSE A_VAL(K)=0 END IF END do END SUBROUTINE GET_OCTETS !} !} ! ----------------------------------------------------------------------------! ! SUBROUTINE PUBLICA: MBUFR.READ_MBUFR | SHSF! ! ----------------------------------------------------------------------------! ! SUBROTINA PARA LEITURA DE UMA MENSAGEM BUFR ! ! ----------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas: ! ! readsec1,readsec2,readsec3,readsec4b,readsec4rd,readsec4cmp expanddesc3 ! ! ----------------------------------------------------------------------------! SUBROUTINE READ_MBUFR(uni, ndmax,sec1,sec3,sec4, bUFR_ED, NBYTES,errsec,select,optsec) !{ Declaracao das Variaveis da entrada INTEGER, intent(in)::uni ! Unidade de leitura INTEGER,intent(in)::ndmax ! Nuumero maximo de descritores para leitura TYPE(selectTYPE),optional,DIMENSION(:),intent(in)::select !} !{ Declaracao das variaveis de saida TYPE(sec1TYPE),intent(out)::sec1 TYPE(sec3TYPE),intent(out)::sec3 TYPE(sec4TYPE),intent(out)::sec4 INTEGER,intent(out):: bufr_ed ! Edicaao do formato BUFR lido INTEGER,intent(out):: nbytes ! Tamanho da mensagem INTEGER,intent(out) :: errsec ! Erro de leitura se 0 indica ! que nao houve erro de leitura ! se >=0 indica o numero da secao ! onde ocorreu o erro (exceto secao0) TYPE(sec2TYPE),optional:: optsec !{ Declaracao das variavaveis locais TYPE(descbufr),pointer,DIMENSION(:)::desc_sec3 ! Descritores da secao3 (ndesc) TYPE(descbufr),pointer,DIMENSION(:)::desc_sec4 ! Descritores da secao4 INTEGER :: ndescmax INTEGER :: tam_sec3, tam_sec3max INTEGER :: tam_sec4, tam_sec4max CHARACTER(len=1):: oct CHARACTER(len=1),DIMENSION(4)::sec0 INTEGER,DIMENSION(2):: a, b INTEGER :: bufrid,un CHARACTER(len=4)::BUFRW CHARACTER(len=4):: sec5id INTEGER :: i, RGINI,RGSEC5,RGSEC2,ERR,errcmp,errrd ,j INTEGER :: tam_sec2 INTEGER :: IFinal INTEGER :: alerr INTEGER :: nvars integer,parameter::currentRGMax=2100000000 !} !{ Este programa ler aquivos de ate 4.2 GBytes IF (CurrentRG>currentRGMax) then print *,"Erro 99: File exceedded ", CurrentRG,"Bytes" errsec=99 return end if !} !} !{ Inicializando variaveis ndescmax=ndmax BUFRW="BUFR" SUBNAME="READ_MBUFR" un=UNI errcmp=0 errsec=0 NVARS=0 IOERR(UN)=0 allocate(desc_sec4(1:ndmax),stat=alerr) allocate(sec3%d(1:1),STAT=alerr) allocate(sec4%r(1:ndescmax,1:1),sec4%d(ndescmax,1:1),sec4%c(ndescmax,1:1),stat=alerr) IF(alerr/=0) THEN print *, "Erro na aloca�o de memoria em READ_mbufr" print *, "pointer desc_sec4(ndmax)" print *, "ndmax=",ndmax errsec=99 return END IF desc_sec4(1:ndmax)%i=0 !} 10 bufrid = 1 !'{ Procura pelo Inicio da proxima secao 0 (palavra "BUFR") !' Quando BUFRID chegar a 4 entao foram enontradas todas as letras de BUFR !' e NBYTES=0 do While (( bufrid <= 4).AND.(IOERR(UN)==0)) IF (IOERR(UN)==0) THEN currentRG = currentRG + 1 read (un,rec= currentRG,iostat=IOERR(UN)) oct IF (IOERR(UN)/=0) RETURN ELSE deallocate(desc_sec4) NBYTES=0 RETURN END IF IF (BUFRW(BUFRID:BUFRID) == oct) THEN bufrid = bufrid + 1 ELSE bufrid = 1 END IF END do !'} --------------------------------------------------------------------------- IF (IOERR(UN)/=0) RETURN !'{ Ler os demais 3 bytes da secao 0 RGINI = currentRG - 3 !' Registro do Inicio da Mensagem DO i = 1, 4 currentRG = currentRG + 1 IF (IOERR(UN)==0) read (un,REC= currentRG) sec0(i) IF(IOERR(UN)/=0) RETURN END DO b(1) = 24 !'Tamanho da mensagem BUFR b(2) = 8 !'nuumero da Edicaao BUFR Call GET_OCTETS(sec0, 4, b, a, 2,0, ERR) NBYTES = a(1) bUFR_ED = a(2) !'}------------------------------------------------------------------------- !'{ VerIFica se a edicao BUFR ee suportada por esta rotina IF ((bUFR_ED < 2).Or.( bUFR_ED > 3)) THEN print *, "**** A V I S O ****" PRINT *,"Esta programa ler as Edicoes 2 ou 3 do formato BUFR" print *,"Mesagens BUFR Ed.", bUFR_ED," podem nao serem lidas corretamente" PRINT *,"" END IF !'}------------------------------------------------------------------------- !'{ VerIFica O FINAL DA MENSAGEM. Se passar por este teste esta !' mesagem possui o tamanho correto RGSEC5 = RGINI + NBYTES - 4 !'Inicio da secao 5 sec5id = "" DO currentRG = RGSEC5, RGSEC5 + 3 IF (IOERR(UN)==0) read (un,rec=currentRG) oct IF (IOERR(UN)/=0) RETURN sec5id = TRIM(sec5id) // oct END do IF (sec5id/="7777") THEN print *, " ** Warning ** Corrupted message at position ",currentRG currentRG=RGINI+4 goto 10 END IF !'}------------------------------------------------------------- !'{ Processar a leitura da sesaao da mensagem a partir da secao 1 !{ Leitura da secao 1 currentRG = RGINI + 7 Call readsec1(un,sec1,err) IF (err/=0) THEN errsec=err print *,"Erro C�igo ",errsec deallocate(desc_sec4) return END IF !} !{ Verifica se a mensagem e do tipo selecionado !-------------------------------------------------------------------- ! Se forem selecionados tipos e subtipos de mensagem BUFR ! verIFica se a mensagem corrente pertence a um dos tipos/substipos ! selecionados. ! Caso afirmativo, continua a leitura da mensagem ! Caso negativo, retorna sem proceder a leitura !------------------------------------------------------------------ IF (present(select)) THEN ! CASO SEJA INFORMADO "none" NA PRIMEIRA POSICAO ! TODOS OS TIPOS SERAO EXCLUIDOS IF (select(1)%bTYPE==none) THEN sec3%nsubsets=0 sec4%nvars=0 GOTO 100 END IF ERRSEC=1 do i=1,ubound(select,1) IF (select(i)%bTYPE==sec1%bTYPE) THEN IF((select(i)%bsubTYPE==sec1%bsubTYPE).or.(select(i)%bsubTYPE==any)) THEN ERRSEC=0 END IF END IF END do END IF IF (ERRSEC==1) THEN sec3%nsubsets=0 sec4%nvars=0 errsec=0 goto 100 END IF !} !{ VerIFica se o dado e do tipo desejado se nao sai !{ se houver secao 2, obtem o tamanho da secao 2 e ! reposiciona registro no final da secao2, para permitir a leitura da proxima ! secao tam_sec2=0 !goto 50 IF(sec1%sec2present) THEN RGSEC2=currentRG if (present(optsec)) then call readsec2(un,tam_sec2,optsec) else call readsec2(un,tam_sec2) end if IF (currentRG>RGSEC5) THEN print *,"Erro na leitura da secao2" errsec=20 goto 100 END IF END IF !} !{ Leitura da secao3 50 tam_sec3max=NBYTES-tam_sec2-30 call READSEC3(un,tam_sec3max,desc_sec3,sec3,tam_sec3,err) IF (err/=0) THEN ! Em muitos casos, as mensagens BUFR nao vem com a secao ! mas, mesmo assim, na secao 1 ee indicado a presenca da secao2 ! isto causa erro na leitura: A secao 2 ee lida no lugar da 3 e ! a 3 no lugar da 4. ! Nesta parte procura-se contornar este problema: ! Quando ocorre erro de leitura na secao 3 e ! sec2_present=true, faz-se uma nova tentativa de ! leitura da secao 3 na posicao da secao2 !{ IF (sec1%sec2present) THEN currentRG=RGSEC2 tam_sec3max=NBYTES-30 call READSEC3(un,tam_sec3max,desc_sec3,sec3,tam_sec3,err) ! Se nao ocorreu erro na leitura da secao3 entao a ! secao 2 nao existe e vai para a leitura da 4 !{ IF (err==0) THEN sec1%sec2present=.false. tam_sec2=0 goto 60 END IF !} END IF !} ! Caso contrario nao le a secao 4 e vai ! para o fim do subrotina ! { print *,"Erro na leitura da secao 3" errsec=err goto 99 !} END IF !} 60 continue !{ Processa a expancao dos descritors IFinal=0 call expanddesc3(desc_sec3,sec3%ndesc,ndescmax,desc_sec4,nvars,IFinal,err) IF (err/=0) THEN errsec=err+50 goto 99 END IF !} !-------------- ! Nota: Caso haja replicadores delayed, ! entaao a expansao dos descritores teraa que ser feitas ! dentro da leitura da secao 4. Neste caso o BUFR naao ! poderaa ser compactado IF (err==0) THEN ! Ou err=4 (Expansao deleyed) tam_sec4max=NBYTES-tam_sec3-tam_sec2-30 deallocate(sec4%r,sec4%d,sec4%c) allocate(sec4%r(1:ndescmax,1:sec3%nsubsets),sec4%d(1:ndescmax,1:sec3%nsubsets),sec4%c(1:ndescmax,1:sec3%nsubsets),stat=alerr) IF (alerr/=0) THEN print *,"Erro na alocacao de espa� para sec4" print *,"sec4%r(ndescmax,sec3%nsubsets)" print *,"sec4%d(ndescmax,sec3%nsubsets)" print *,"sec4%c(ndescmax,sec3%nsubsets)" print *,"ndescmax=",ndescmax print *,"sec3%nsubsets" stop END IF IF ((sec3%is_cpk==0).and.(IFinal0) THEN do j=1,sec3%nsubsets Do i=1,nvars sec4%d(i,j)=desc_sec4(i)%f*100000+desc_sec4(i)%x*1000+ desc_sec4(i)%y sec4%c(i,j)=desc_sec4(i)%i END do END do END IF !} ELSE nvars=0 errsec=50+err END IF !-------------! ! Finalizacao ! !-------------! 99 deallocate(desc_sec3) 100 deallocate(desc_sec4) currentRG=RGINI+NBYTES-1 ! POSICIONAMENTO NO FINAL DA MENSAGEM NMSG=NMSG+1 END SUBROUTINE read_mbufr !} ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.READSEC1 | SHSF! ! ----------------------------------------------------------------------------! ! LER DADOS DA SECAO 1 E VERIFICA A COMPATIBILIDADE DAS ! TABELAS BUFR DA MENSAGEM COM A TABELA CARREGADA POR ESTE ! MOODULO ! ! ! ----------------------------------------------------------------------------! ! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:GET_OCTETS, check_vertables ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! ! 03/08/2006 : Corrigido leitura dos minutos (Sergio e Ana L. Travezan) !_____________________________________________________________________________! SUBROUTINE READSEC1(un,sec1e,sec1err) !{ Declaracao de variaveis da interface INTEGER,intent(in)::un TYPE(sec1TYPE),intent(out)::sec1e INTEGER,intent(inout)::sec1err !} !{ Declaracao de variaveis locais CHARACTER(len=1):: sec1(18) INTEGER,DIMENSION(16) :: b, a INTEGER :: i,err INTEGER :: LOCALTABLE INTEGER :: MASTERTABLE !} !{ Inicializar variaveis A(1:15)=0 sec1err=0 SUBNAME="READSEC1" !'{ Ler octetos da secao 1 do i = 1,18 currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG) sec1(i) IF (IOERR(UN)/=0) RETURN END do !'} !'{ Obter valores de cada um dos octetos lidos b(1) = 24 !'Tan_sec1 = Tamanho da secao 1 b(2) = 8 !'BUFR Master Table Se 0 ee a tabela padrao b(3) = 8 !'Sub centro gerador b(4) = 8 !'Centro gerador b(5) = 8 !'Numero da Atualizacao b(6) = 1 !'secao 2 incluida b(7) = 7 !' Tudo Zero b(8) = 8 !' Categora dos dados b(9) = 8 !' sub-categoria dos dados b(10) = 8 !' Versao da tabela mestre usada b(11) = 8 !' versao da tabela local usada b(12) = 8 !' Ano do seculo b(13) = 8 !' MES b(14) = 8 !'DIA b(15) = 8 !'hORA b(16) = 8 !'minuto Call GET_OCTETS(sec1, 18, b, a, 16,0, ERR) IF (ERR < 0) THEN print*,"Erro leitura secao1" sec1err=11 return END IF IF (a(1) /= 18) THEN print *,"Erro Tamanho da secao 1" sec1err=12 return END IF sec1e%year = a(12) sec1e%month = a(13) sec1e%day = a(14) sec1e%hour = a(15) sec1e%minute = a(16) sec1e%bTYPE = a(8) sec1e%bsubTYPE = a(9) sec1e%subcenter=A(3) sec1e%center = a(4) MasterTable=a(10) LocalTable=a(11) sec1e%MasterTable=a(10) sec1e%LocalTable=a(11) IF (a(6) == 1) sec1e%sec2present = .True. IF (sec1e%year<1900) THEN IF (sec1e%year>50) THEN sec1e%year=1900+sec1e%year ELSE sec1e%year=2000+sec1e%year END IF END IF ! VerIFica se e a tabela padrao da WMO IF (a(2)/=0) THEN print *,"Erro! Este mensagem BUFR nao utiliza a tabela mestre padrao" sec1err=13 return END IF sec1err=check_vertables(sec1e%center,MasterTable,LocalTable) IF (sec1err>0) return END SUBROUTINE readsec1 ! ----------------------------------------------------------------------------! ! FUNCAO PRIVADA INTEGER : MBUFR.check_vertables | SHSF! ! ----------------------------------------------------------------------------! ! VerIFica se a tabela BUFR em uso no modulo ee compativel com outra ! tabela BUFR e retorna um dos flag de erro abaixo ! ! ! 0 | Tabela compativel ! 14 | Tabela Master Desatualizada ! 15 | Necessario outra tabela Local ! ! A verificacao dividi-se em 2 partes: ! ! PARTE A) Verifica se a tabela Master est�desatualizada ! ! PARTE B) ! Verifica se a versao da tabela local e compativel com a tabela usada. ! ! As tabelas sao consideradas compativeis em dois casos ! c1- Se Versao da tabela local = 0 (NAO IMPORTA o centro gerador ) ! c2 -Se versao da tabela local > 0, com MESMO centro gerador ! ----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! function check_vertables(center,Mastertable,localtable) INTEGER :: check_vertables INTEGER,intent(in)::center,Mastertable,localtable INTEGER:: err !{ PARTE A IF (VerMasterTab0).or.(VerLoctab>0)) THEN IF((VerLoctab/=LocalTable)) THEN call reinittables(Center,Mastertable,localtable,err) IF (err>0) THEN print *,"Erro 15! ",ERROMESSAGE(15) print *,"It's Necessary Local table=",LocalTable," of center=",center, " Master table=",mastertable check_vertables=15 return END IF END IF END IF check_vertables=0 END function check_vertables !-----------------------------------------------------------------------------! ! SUB-ROTINA PRIVADA: MBUFR.READSEC2 | SHSF! ! ----------------------------------------------------------------------------! ! Esta subroutina obtem o tamanho da secao 2 ! e posiciona o currentRG ao final desta secao, afim ! de permitir a leitura da proxima secao ! ! Nota: 1 - No momento, esta subrotina nao processa os dados ! contidos na secao 2 ! 2- Antes de utilizar esta subrotina, certIFique-se ! que a secao 2 exista REALmente (flag da secao1) e ! que o currentRG esteja apontando para o final ! da secao1 ! ! !-------------------------------------------------------------------------- ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:GET_OCTETS ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE READSEC2(unI,tam_sec2,optsec) !{ Variaveis da interface INTEGER,intent(in)::unI INTEGER,intent(out)::tam_sec2 type(sec2type),optional,intent(out)::optsec !} !{ variaveis locais INTEGER,DIMENSION(15) :: b(1), a(1) INTEGER ::i,err CHARACTER,DIMENSION(3)::sec2 INTEGER ::antsec2RG ! Registro anterior ao inicio da secao2 INTEGER ::un,noct !} !{ Inicializar variaveis un=unI A(1)=0 SUBNAME="READSEC2" antsec2RG=currentRG !Guarda o registro anterior ao inicio da secao2 !} !{ Ler os 3 primeiros bytes da da secao 2 do i=1,3 currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(un)) sec2(I) IF (IOERR(UN)/=0) RETURN END do !} !'{ Obter valores de cada um dos octetos lidos b(1) = 24 !' Tamanho da secao 2 tem 24 bits Call GET_OCTETS(sec2, 3, b, a, 1, 0,ERR) IF (ERR < 0) THEN print*,"Erro leitura secao2" err=20 return END IF tam_sec2=a(1) ! Repassa o tamanho da secao2 IF (tam_sec2<4) THEN print *,"Erro na secao2" stop END IF if (present(optsec)) then !{ Ler a secao 2 noct=tam_sec2-4 allocate(optsec%oct(1:noct),stat=err) if (err>0) then err=20 return end if optsec%nocts=noct currentRG=currentRG+1 ! Pula o byte reservado do i=1,noct currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(un)) optsec%oct(I) IF (IOERR(UN)/=0) RETURN END do endif !{ Posiciona o registro corrente no final da secao2 currentRG=antsec2RG+tam_sec2 !} END SUBROUTINE readsec2 !-----------------------------------------------------------------------------! ! SUB-ROTINA PRIVATIVA: MBUFR.READSEC3 | SHSF! ! ----------------------------------------------------------------------------! ! ! Esta sub-rotina obtem os descritores da secao 3, ! ! Nota: Antes de utilizar esta rotina, certIFique-se que ! currenteRG esteja apontando para o final da secao ! anterior (secao1 ou 2) ! !-------------------------------------------------------------- !Octeto Descriaao !1-3 Tamanho da Sessaao 3 !4 Zeros (reservado) !5-6 Nuumero de subsets !7 Bit 1 ! 1= dados observados, 0= outros dados ! ! Bit 2 1= dados comprimidos, 0= dados naao comprimidos ! Bit 3 - 8 Zeros !-------------------------------------------------------------------------- ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:GET_OCTETS ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE READSEC3(UN,tam_sec3max,d,sec3e,tam_sec3,err_sec3) !{Declaracao das variaveis de entrada INTEGER, intent(in)::UN INTEGER,intent(in)::tam_sec3max ! Tamanho maximo da secao 3 ! Se o tamanho REAL da secao3 ! for maior que tam_sec3max, ! existe um erro na mensagem !} !{ Declaracao de variaaveis de saida TYPE(descbufr),pointer,DIMENSION(:)::D ! Descritores INTEGER,intent(inout)::tam_sec3 TYPE(sec3TYPE),intent(out)::sec3e INTEGER,intent(out)::err_sec3 !} !{ Declaracao das variaveis locais CHARACTER(len=1),DIMENSION (7):: sec3 ! A identIFicacao da secao 3 tem 7 bytes CHARACTER(len=1),allocatable::sec3b(:) INTEGER,allocatable::A(:) INTEGER,allocatable::B(:) INTEGER,DIMENSION(7):: A1,B1 INTEGER :: uni ,i ,xx,ib,err,aerr INTEGER :: ndesc uni=un err=0 err_sec3=0 SUBNAME="READSEC3" !'{ Leitura dos 7 primeiros octetos da secao 3 do i = 1,7 currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) sec3(i) IF (IOERR(UN)/=0) RETURN END do !} !{ Decoficacao dos 7 primeiros bits B1(1)=24 ! Tamanho da Secao 3 b1(2)=8 ! byte reservado (bite 4) b1(3)=16 ! Numero de data subsets (observacoes em cada registro BUFR) byte b1(4)=1 ! se 1 Indica dados observacionais b1(5)=1 ! se 1 Indica dados comprimidos b1(6)=6 ! Demais bits do octeto ee 0 (byte 7) Call GET_OCTETS(sec3, 7, b1, a1, 6, 0,ERR) IF (ERR < 0) THEN !print*,"Erro leitura secao3" err_sec3=30 END IF !{ Calculando e alocando espaco para leitura dos descritores tam_sec3= a1(1) IF(tam_sec3>=tam_sec3max) THEN err_sec3=30 return END IF ndesc=(tam_sec3-7)/2 allocate(D(1:ndesc),STAT=aerr) IF(aerr>0) THEN print *,"Erro na alocacao de memoria para secao 3" stop END IF allocate(sec3b(1:tam_sec3),stat=aerr) IF(aerr>0) THEN print *,"Erro na alocacao de memoria para secao 3" stop END IF deallocate(sec3e%d) allocate(sec3e%d(1:ndesc),STAT=aerr) IF(aerr>0) THEN print *,"Erro na alocacao de memoria para secao 3" stop END IF allocate(A(1:ndesc*4),B(1:ndesc*4),STAT=aerr) IF(aerr>0) THEN print *,"Erro na alocacao de memoria para secao 3" stop END IF !} sec3e%nsubsets = a1(3) sec3e%is_obs = a1(4) ! se 1 e dados observacional sec3e%Is_cpk = a1(5) ! Se 1 e dados comprimidos sec3e%ndesc=ndesc !} Fim da leitura e decodIFicacao dos 7 primeiros bits !{ Verificacao preliminar de erros de leitura da secao 3 IF (tam_sec3<8) THEN ERR_sec3=31 return END IF !} IF(sec3e%nsubsets<1) THEN ERR_sec3=32 return END IF !{ Leitura dos descritores !{ Preparando vetor com o numero dos bits ib=0 do i=1,Ndesc ib=ib+1;b(ib)=2 ib=ib+1;b(ib)=6 ib=ib+1;b(ib)=8 END do !} xx=tam_sec3-7 ! Numero de octeros que contem os descritores !{ LENDo os octetos que contem os descritores do i = 1,xx currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) sec3b(i) IF (IOERR(UN)/=0) RETURN END do !} !{ Separando os descritores Call GET_OCTETS(sec3b, xx, b, a, ib,0, ERR) ib=0 do i=1,ndesc ib=ib+1;D(i)%f=a(ib) ib=ib+1;D(i)%x=a(ib) ib=ib+1;D(i)%y=a(ib) sec3e%d(i)=d(i)%y+d(i)%x*1000+d(i)%f*100000 END do !} !} Fim da Leitura dos descritores deallocate (a,b,sec3b) END SUBROUTINE readsec3 !-----------------------------------------------------------------------------! ! SUB-ROTINA PRIVATIVA: MBUFR.READSEC4B | SHSF! ! ----------------------------------------------------------------------------! ! ! Esta subrotina "le" os dados da secao 4 (nao compactada e sem replicadores ! pos-postos). ! ! ! Nota: Antes de utilizar esta rotina, certIFique-se que: ! ! a) currenteRG esteja apontando para o final da secao ! anterior (secao 3) ! b) Nao esteja sENDo utilizado descritores replicadores pos-postos ! !-----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:GET_OCTETS,tabc_setparm,cval ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! SUBROUTINE READSEC4b(UN,D,ndesc,nsubset,sec4e,tam_sec4,erro4b) !{ Variaveis da Interface TYPE(descbufr),pointer,DIMENSION(:)::D ! Descritores BUFR INTEGER,intent(in)::UN ! Unidade de leitura INTEGER,intent(in)::ndesc ! Nuumero de descritores INTEGER,intent(in)::nsubset ! Nuumero de "subsets" TYPE(sec4TYPE),intent(out)::sec4e ! Dados da secao 4 INTEGER,intent(out)::tam_sec4 ! tamanho da secao 4 (bytes) INTEGER,intent(out)::erro4b ! Codigo de erro na leitura da secao 4 !} !{ Variaveis locais INTEGER,DIMENSION((nsubset*(ndesc+5)*4))::A,B ! A(:)= Vetor para receber os dados decodIFicados ! B(:)= Nuumero de bits de cada valor de A(:) CHARACTER(len=1),allocatable :: sec4(:) ! Vetor para receber os octetos da secao 4 !} !{ Variaveis auxiliares CHARACTER(len=1),DIMENSION(4)::auxsec4 INTEGER :: uni ,k,err,j ,i,xx !} !{ Inicializacao de variaveis uni=un SUBNAME="READSEC4b" erro4b=0 deallocate(sec4e%r,sec4e%d,sec4e%c) allocate(sec4e%r(1:ndesc,1:nsubset),sec4e%d(1:ndesc,1:nsubset),sec4e%c(1:ndesc,1:nsubset),stat=err) IF (err>0) THEN print *,"Erro na alocao de memoria da secao 4" stop END IF !} !'{ Leitura dos 4 primeiros octetos da secao 4 do i = 1,4 currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) auxsec4(i) IF (IOERR(UN)/=0) RETURN END do !} !{ Obtem o tamanho da secao 4 b(1)=24 ! Tamanho da secao 4 Ainda naao e conhecido b(2)=8 ! byte reservado (= 0) Call GET_OCTETS(auxsec4, 4, b, a, 2,0, ERR) IF (ERR < 0) THEN print*,"Erro leitura secao4" Stop END IF tam_sec4=a(1) xx=tam_sec4 ! Numero de octeros que contem os descritores allocate(sec4(1:xx),stat=err) IF (err>0) THEN print *, "Erro na alocacao de memoria para leitura da secao 4 b" stop END IF !} !{ LENDo os octetos que contem os dados da secao 4 do i = 1,xx currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) sec4(i) IF (IOERR(UN)/=0) RETURN END do !} !{ Extraindo os valores do octetos lidos k=0 do i=1,nsubset call tabc_setparm(err=err) do j=1, ndesc k=k+1 b(k)=bits_tabb2(d(j)) END do END do Call GET_OCTETS(sec4, xx, b, a, k,0, ERR) IF (ERR<0) THEN erro4b=41 deallocate(sec4) return END IF !} !{ Decodificando valores k=0 do i=1,nsubset j=0 do while (j0) THEN print *,TRIM(SUBNAME),": Erro na aloca�o de memoria" print *,"sec4e%d(ndxmax,nsubsets)" print *,"sec4e%r(ndxmax,nsubsets)" print *,"sec4e%c(ndxmax,nsubsets)" print *,"ndxmax=",ndxmax print *,"nsubsets=",nsubsets stop END IF allocate(dx(1:ndxmax),STAT=err) IF (err>0) THEN print *,TRIM(SUBNAME),": Erro na alocacaao de memoria" stop END IF !'{ Leitura dos 4 primeiros octetos da secao 4 do i = 1,4 currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) auxsec4(i) IF (IOERR(UN)/=0) goto 800 END do !} !{ Obteem o tamanho da secao 4 b1(1)=24 ! Tamanho da secao 4 Ainda naao e conhecido b1(2)=8 ! byte reservado (= 0) Call GET_OCTETS(auxsec4, 4, b1, a1, 2,0, ERR) IF (ERR < 0) THEN print*,"Erro leitura secao4" Stop END IF tam_sec4=a1(1) !} xx=tam_sec4-3 ! Numero de octeros que conteem os descritores allocate(a(1:xx*8),b(1:xx*8),sec4(tam_sec4),STAT=err) IF (err>0) THEN print *,"Erro na alocacao de memoriaem readsec4rd" print *,"a(xx),b(xx),sec4(tam_sec4)" print *,"xx=",xx print *,"tan_sec4=",tam_sec4 stop END IF !{ lendo os octetos que contem os dados da secao 4 do i = 1,xx currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) sec4(i) IF (IOERR(UN)/=0) goto 800 END do !} ! { Extraindo os valores do octetos lidos nvars_maxsubset=0 do i=1,nsubsets IFinal=0 ! E zerado a cada subset, para re-iniciar a expansaao dos ! replicadores delayed 444 call expanddesc3(d,ndesc,ndxmax,dx,nvars,IFinal,err) cbits=0 k=0 IF (xx*8nvars_maxsubset) nvars_maxsubset=IFinal sec4e%nvars=nvars_maxsubset !} Fim da decodIFicaccaao END do !} ! Fim da leitura da seccaao 4 800 deallocate(a,b,sec4,dx) END SUBROUTINE READSEC4rd2 !-----------------------------------------------------------------------------! ! SUB-ROTINA PRIVATIVA: MBUFR.READSEC4CMP | SHSF! ! ----------------------------------------------------------------------------! ! OBJETIVO: LEITURA DA SECAO 4 COMPACTADA !-----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:GET_OCTETS,tabc_setparm,cval ! SUBROUTINE READSEC4CMP(UN,D,ndesc,nsubset,sec4e,tam_sec4,errsec4) !{ Variaveis de entrada TYPE(descbufr),pointer,DIMENSION(:)::D ! Descritores BUFR INTEGER, intent(in)::UN ! INTEGER,intent(in)::ndesc ! Numero de descritores INTEGER,intent(in)::nsubset !} !{ variaveis de saida TYPE(sec4TYPE),intent(out)::sec4e INTEGER,intent(out)::tam_sec4 INTEGER,intent(out)::errsec4 !} INTEGER,DIMENSION((nsubset*(ndesc+5)*4))::A,B ! Vetor de Valores e Numero de bits de cada valor CHARACTER(len=1),allocatable :: sec4(:) ! Valor anterior e 28 CHARACTER(len=1),DIMENSION(4)::auxsec4 INTEGER :: uni ,k,err,j ,i INTEGER::xx,kmax,aerr INTEGER :: vmini ! Auxiliar para valor minimo (inteiro) INTEGER :: bbit ! Auxiliar para quantidade de bits compactos REAL :: VMINI2 uni=un SUBNAME="READSEC4CMP" errsec4=0 !{ Incializa os paramentros "defaut" da tabela C call tabc_setparm(err=err) !} !'{ Leitura dos 4 primeiros octetos da secao 4 do i = 1,4 currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) auxsec4(i) IF (IOERR(UN)/=0) RETURN END do !} !{ Obtem o tamanho da secao 4 b(1)=24 ! Tamanho da secao 4 Ainda naao e conhecido b(2)=8 ! byte reservado (= 0) Call GET_OCTETS(auxsec4, 4, b, a, 2,0, ERR) IF (ERR < 0) THEN errsec4=1 return END IF tam_sec4=a(1) xx=tam_sec4-3 ! Numero de octeros que contem os dados allocate(sec4(1:xx),stat=aerr) IF (aerr>0) THEN print *,"Erro na alocacaao de memoria p leitura da secao 4" stop END IF !} !{ LENDo os octetos que contem os dados da secao 4 do i = 1,xx currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG,IOSTAT=IOERR(UN)) sec4(i) IF (IOERR(UN)/=0) RETURN END do !} ! { Extraindo os valores do octetos lidos (compactados) ! k=0 !{ Nesta fase obtem-se todos os valores minimos ! para compactacao e tambem os numeros de bits ! de cada valor arquivado do j=1, ndesc !--------------------------------------------------------- !ObtENDo o numero de bits de todos os dados, ou seja, !ObtENDo o numero de bit de cada descritor j da tabela B !--------------------------------------------------------- !{ IF (d(j)%f==0) THEN k=k+1; b(k)=bits_tabb2(d(j)) k=k+1; b(k)=6 Call GET_OCTETS(sec4, xx, b, a, k, K-2,ERR) IF (ERR < 0) THEN errsec4=1 exit END IF vminI=a(k-1) bbit=a(k) VMINI2=CVAL(vmini,D(J)) IF (vmini==null) THEN vmini=0 bbit=0 END IF IF (int(bbit)>b(k-1)-tabc%dbits) THEN ! Espera-se que o nmero de bits compactados sejam ! Menores que o nmero de bits definidos na tabela B ! do Contraario nao haveria sentido em processar o ! BUFR compactado. Assim sENDo esta informacao e ! suspeita de erro de leitura/codIFicacao BUFR ! print *,"Aviso ! Numero de bits muito grande. (Variavel ",j,")" END IF ! } ! { Replicando o numero de bits para todos os ! sub-conjuntos do descritor j do i=1,nsubset k=k+1 b(k)=bbit END do ELSE !No caso de descritor da tabela C, nao processa-se o ! salto para o proximo B(k) e A(k). ! O mesmo procedimento e utilizado na descompactacao mais adiante ! afim de compensar o numero menor de A(k) em relacao ao numero ! de descritores ! CALL tabc_setparm(d(j),err) IF (err==0) THEN print *,"Modificadores da tabela C presentes em j=",j,d(j)%x !stop END IF END IF END do ! Neste ponto k representa o numero total de ! elementos em sec4, incluindo valores minimos (vmin) ! e numero de bits. O vetor b(k) contem o numero de bits ! de todos estes elementos. ! ! Esta ultima chamada de get_OCTETS e realizada para ! obter todos os dados compactados para em seguida ser feita ! a descompactacao kmax=k Call GET_OCTETS(sec4, xx, b, a, kmax,0, ERR) IF (ERR < 0) THEN errsec4=1 !return END IF !{ **** Descompactacaao ***** k=0 do j=1, ndesc IF (d(j)%f==0) THEN k=k+1 vmini=a(k) k=k+1 ! < Salta o numero de bits que agora nao e mais necessario do i=1,nsubset k=k+1 IF ((vmini.ne.null)) THEN sec4e%r(j,i)=CVAL(a(k)+vmini,d(j)) ELSE sec4e%r(j,i)=null END IF sec4e%d(j,i)=d(j)%f*100000+d(j)%x*1000+d(j)%y sec4e%c(j,i)=d(j)%i END do ELSE ! Se for descritor da tabela C, coloca o descritor em ! sec4%d, processa tabc_setparm, porem nao salta para ! o proximo valor de a(k), b(k), pois estes nao consideraram ! a existencia destes descritores ! Note que os descritores que modificam o numero de ! bits n� tem mais efeito nesta parte do programa, pois ! estes valors ja foram utilizados para leitura dos bits ! no arquivo BUFR. ! ! Os fatores de escala e referencia s� usados apenas em CVAL ! para obter os valores corretos !{ CALL tabc_setparm(d(j),err) do i=1,nsubset sec4e%d(j,i)=d(j)%f*100000+d(j)%x*1000+d(j)%y sec4e%r(j,i)=null END do END IF END do deallocate (sec4) END SUBROUTINE READSEC4CMP !-----------------------------------------------------------------------------! ! SUB-ROTINA PRIVATIVA: MBUFR.EXPANDDESC3 | SHSF! ! ----------------------------------------------------------------------------! ! ROTINA GENERICA DE EXPANSAO DE DESCRITORES ! ! Esta rotina recebe os descritores que sao lidos ou gravados ! na secao 3 (Descritores da Tabela B e D e replicadores) ! Os descritores D sao expandidos para os descritores da tabela B ! e os replicadores sao utilizados para replicar os descritores ! da tabela B, com execessao dos descritores replicadores pospostos. ! ! Ao final do processo de expansao a maior parte dos descritores ! estaram convertidos em descritores da tabela B ! (Descritores expandidos) ! ! Os descritores naao expandidos por esta rotina saao ! 1) Descritores da tabela C ! 2) Descritores replicadores pospostos (delayed replicators) ! ! No caso dos descritores replicadores pospostps, a rotina interrompe ! a expansao. Neste caso o vetor dx tera parte dos descritores expandidos ! e parte naao expandidos. A variavel IFinal guardara o ! indice do descritor de fator de replicaao, que sucede ! o replicador posposto ! ! ! Erros ! 0 = Nao ocorreu erros ! 1 = Descritor desconhecido (tabela D) Erro cod 50 ! 2 = Descritor desconhecido (tabela B) Erro cod 51 ! 3 = Descritor replicador com erro Erro cod 52 ! 4 = Expancao incompleta (Um erro desconhecido resultou em um ! descritor que nao e da tabela B) ! ! Nota: Esta rotina nao replica um descritor replicador (replicacao recursiva) ! Embora seja logico a replicacao recursiva, nao existe nos manuais ! da WMO nenhum comentario a respeito desta possibilidade. Tambem nao encontrei ! ate o momento nenhuma mensagem utilizando deste recurso. ! Desta forma, por facilidade de programacao, nao implementei ! esta rotina com replicacao recursiva. ! ! !-----------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:expandsubdesc,replicdesc,expandescD ! ! ----------------------------------------------------------------------------! SUBROUTINE expanddesc3(di,ndi,ndxmax,dx,nvars,IFinal,err) !{ Variaveis de Interface TYPE(descbufr),pointer,DIMENSION(:)::di ! Descritores compactos para a secao 3 INTEGER,intent(in)::ndi ! Numero de descritores em di INTEGER,intent(in)::ndxmax ! Numero maximo estimado de descritores expandidos TYPE(descbufr),pointer,DIMENSION(:)::dx ! Descritores expandidos para a secao 4 INTEGER,intent(inout):: nvars ! Nuumero de variaavies (descritores ate a expansaao) INTEGER,intent(inout)::IFinal ! Indice do ultimo descritor expandido. ! Nota: Se todos os descritores forem expandidos, esta subrotina retorna IFinal=nvars ! Caso contrario, i.e., caso exista replicadores pospostos, entaao IFinal0) THEN IFinal=idelayed i=idelayed ELSE IFinal=nd END IF END do !} !{Expandir descritores da tabela D 0 i=0 exist_tabd=.false. DO while (i 0 Indica o uultimo descritor vinculado a um replicador delayed INTEGER,intent(inout)::err ! Se 0 Indica que nao houve erro na expancao dos descritores !} !{ variaveis locais !INTEGER::ndxmax ! Numero maximo estimado de descritores expandidos INTEGER ::i ! Indice para descritores nao expandido INTEGER ::k ! Indice para descritores expandidos INTEGER ::j INTEGER ::ix,iy,jx,jy,ydelayed TYPE(descbufr),DIMENSION(ndescmax)::dc !} !{ Inicializa variaveis i=0;k=0;j=0;err=0; idelayed=0 ! Se for um descritor replicador do tipo ! F=01, X =jx Y = jy, entao os proximos jx descritores ! serao replicados jx vezes. Se jy=0 entao e um descritor ! replicador "deleyed". que ainda nao e tratado por este ! programa IF ((desc(idesc)%f==1).and.(desc(idesc)%x/=0)) THEN !{1 !{ Copia os descritores desc para dc do i=idesc,ndesc dc(i)=desc(i) END do !} i=idesc k=idesc j=0 IF(dc(i)%y>0) THEN !{2 !{ Processa a replicacao dos descritores vinculados ao replicador. ! Neste precesso o descritor replicador e excluido de desc() jy=dc(i)%y jx=dc(i)%x do iy=1,jy do ix=1,jx !jx descritores em cd serao replicados !IF (TABB(dc(I+ix)%f,dc(I+ix)%x,dc(I+ix)%y)%nbits==0) err=2 !IF (dc(I+ix)%f==1) err=3 ! nao replicar um descritor replicador desc(k)=dc(i+ix) k=k+1 IF (k>ndescmax+1) THEN print *,"Erro 54!",ERROMESSAGE(54) print *,"NDESCMAX=",ndescmax err=54 return END IF END do !ix END do !iy !{ Coopia de volta os descritores nao vinculados ! ao replicador do i=idesc+jx+1,ndesc desc(k)=dc(i) k=k+1 END do !{ Atualiza ndesc ndesc = k-1 !} ELSE !(IF d(i)%y==0) (Replicador delayed) ! Caso seja um replicador delayed então verIFica e obtem o código 0-31-y e os demais ! descritore, vinculados a este replicador !{ IF ( (dc(idesc+1)%f/=0).and.(dc(idesc+1)%x/=31)) THEN err=55 ! Erro na utilização de replicador delayed ELSE ydelayed=dc(idesc+1)%y idelayed=idesc+1!+dc(idesc)%x END IF ! return END IF !2} END IF !} Fim da replicacao END SUBROUTINE replicdesc !-------------------------------------------------------------------------------! ! SUB-ROTINA PUBLICA: MBUFR.printchar_mbufr | SHSF | ! ------------------------------------------------------------------------------! ! printchar_mbufr - Rotina gravar uma linha texto entre ! mensagens BUFR ! Obs.: Esta rotina eventualmente ser útil, quando se deseja acrescenter ! informações adicionais ao arquivo, tais como, cabeçalho de ! telecomunicações. !-----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! ! SUBROUTINE printchar_mbufr(un,line) ! INTEGER,intent(in)::un ! CHARACTER(len=*),intent(in)::line ! ! INTEGER ::l ! ! l=len_trim(line) ! ! do i=1,l ! ! ! END do ! END SUBROUTINE !-------------------------------------------------------------------------------! ! SUB-ROTINA PUBLICA: MBUFR.tabc_setparm | SHSF | ! ------------------------------------------------------------------------------! ! ! Esta subrotina configura parametros de ! funcionamento do MBUFR, conforme ! descritores tabela Bufr C de cada mensagem ! ! Entrada: Descritores ! Saida : Parametros de configura�o ! ! Descritores da Tabela C que s� processados ! ! 2-01-Y - "Adiciona Y-128 Bits ao comprimento de ! cada elemento da tabela B" (desde que seja numerico) ! (Parametro tabc%dbits) ! 2-02-y - "Adiciona Y-128 Bits ao fator de escala ! de cada elemento da tabela B,exceto os ! que naao saao codigos ou flag tables ! (Paraametro tabc%dscale) ! ! 2-03-y "O descritor subsequente define o novo valor ! de referencia. Cada valor de referencia e ! definido por Y bits na secao de dados. Os ! valores negativos saao definidos pelo bit1=1 ! 2-06-Y " Os proximos Y bits serao descritos pelo proximo ! ! descritor, que e um descritor local. ! ! !-----------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! SUBROUTINE tabc_setparm(desc,err) TYPE(descbufr),optional,intent(in)::desc ! Descritores INTEGER,intent(out)::err ! Codigo de erro (se err=0 nenhum erro ocorreu INTEGER::flag_err ! Bandeira de erro err=80 ! Descritor da tabela C nao processado ou encontrado IF (present(desc)) THEN IF (desc%f==2) THEN flag_err=1 IF (desc%x==1) THEN IF (desc%y>0) THEN tabc%dbits=tabc%dbits+desc%y-128 ELSE tabc%dbits=0 END IF flag_err=0 END IF IF (desc%x==2) THEN IF (desc%y>0) THEN tabc%dscale=tabc%dscale+desc%y-128 ELSE tabc%dscale=0 END IF flag_err=0 END IF IF (desc%x==3) THEN tabc%vref=desc%y flag_err=0 END IF IF (desc%x==6) THEN tabc%nlocalbits=desc%y flag_err=0 ENDIF IF (desc%x>10) flag_err=0 IF(flag_err>0) THEN print *,"Erro 51 ",ERROMESSAGE(51) print *,"Descritor:",desc%f,desc%x,desc%y err=51 return END IF END IF ELSE tabc%dbits=0 tabc%dscale=0 tabc%vref=255 tabc%nlocalbits=0 err=0. END IF END SUBROUTINE tabc_setparm !-------------------------------------------------------------------------------! ! FUNCAO INTEIRA : bits_tabb2 | SHSF! ! ------------------------------------------------------------------------------! ! ! Retorna numero de bits de um descritor da tabela B ! ! A tabela B contem o numero de bits de cada um dos descritores. ! Contudo este numero pode ser modIFicado em 2 situa�es ! ! a) Quando um descritor da tabela C altera descritores da tabela B ! ! b) Quando utilizado sub-descritore da tabela B ! ! Nota : Os sub-descritores nao faze parte do BUFR padrao. ! trata-se de uma tecnica utilizada neste programa para ! simplIFicar a manipulacao de descritores do tipo ASCII ! ! No caso de descritores to tipo ASCII procede-se a subdivisao ! em subescritore com numero de bits = 9, isto e, 1 byte !--------------------------------------------------------------------- !-----------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! function bits_tabb2(d);INTEGER :: bits_tabb2 !{ Variaveis de interface TYPE(descbufr),intent(in)::d !} INTEGER::bits INTEGER::err !{ Valor inicial bits=0 !} !{ Caso nao seja um descritor da tabela B retorna valor zero IF (d%f/=0) THEN call tabc_setparm(d,err) return END IF !} !{ Obtem numero de bits do descritor da tabela B, levando em ! consideracao as alteracoes de numero de bits causados por ! descritores da tabela C IF (d%i==0) THEN bits=tabb(d%f,d%x,d%y)%nbits+tabc%dbits IF (bits==0) bits=tabc%nlocalbits tabc%nlocalbits=0 ELSE bits=8 END IF !} bits_tabb2=bits END function !------------------------ !-------------------------------------------------------------------------------! ! FUNCAO PRIVATIVA REAL : MBUFR.CVAL | SHSF! ! ------------------------------------------------------------------------------! ! CVAL(A,D) : Retorna um valor REAL de um inteiro "A" (secao 4 do BUFR) ! ! atraves da aplicacao do fator de escala e referencia determinado! ! pelo descritor "D" ! ! ! ! Obs.: ! ! 1-Esta rotina inclui as modificacoes da tabela B previamente ! ! configuradas por descritores da tabela C ! ! ! ! 2-Funcao inversa a CINT (vide CINT) ! !-------------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! !-------------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_______________________________________________________________________________! FUNCTION cval(a,d);REAL:: cval !{ Variaveis de entrada INTEGER,intent(in) :: a ! Valor inteiro (BUFR secao 4) TYPE(descbufr),intent(in)::d ! Descritor (tabela B) relativo ao valor a !} !{ Variaveis locais INTEGER::scale ! Fatos de escala INTEGER :: refv ! Valor de referencia INTEGER :: err ! Codigo de erro !} cval=0.0 IF (d%f/=0) THEN call tabc_setparm(d,err) return END IF !{ Obtem o fator de escala scale=tabb(d%f,d%x,d%y)%scale+tabc%dscale !} !{ Obtem o valor de referencia IF (tabc%vref==255) THEN refv=tabb(d%f,d%x,d%y)%refv ELSE refv=tabc%vref ENDIF !} !{ Decodifica o valor Inteiro para REAL CVAL=REAL(a+refv)/REAL(10.0**scale) !{ CASO SEJA VALOR ASC N� PERMITE QUE VALORES ASC<32 SEMA UTILIZADOS IF ((d%I>0).and.(CVAL<32)) CVAL=32 !} !} END function cval !{ !-------------------------------------------------------------------------------! ! FUNCAO PRIVATIVA INTEIRA : MBUFR.CINT | SHSF ! ! ------------------------------------------------------------------------------! ! CINT(V,D) : Retorna um valor INTEIRO (secao 4 BUFR) de um REAL "V" ! ! atraves da aplicacao do fator de escala e referencia determinado! ! pelo descritor "D" ! ! ! ! Obs.: ! ! 1-Esta rotina inclui as modificacoes da tabela B previamente ! ! configuradas por descritores da tabela C ! ! ! ! 2-Funcao inversa a CVAL (vide CVAL) ! !-------------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! !-------------------------------------------------------------------------------! function cint(v,d);INTEGER::cint !{ Variaveis da interface REAL,intent(in)::v ! Valor REAL a ser convertido em BUFR TYPE(descbufr),intent(in)::d ! Descritor correspondente !} !{ Variaveis locais INTEGER::scale INTEGER:: refv INTEGER :: err !} cint=0 IF (d%f/=0) THEN call tabc_setparm(d,err) return END IF !{ Obtem o fator de escala scale=tabb(d%f,d%x,d%y)%scale+tabc%dscale !} !{ Obtem o valor de referencia IF (tabc%vref==255) THEN refv=tabb(d%f,d%x,d%y)%refv ELSE refv=tabc%vref ENDIF !} !{ Calcula o valor inteiro para "BUFRIZACAO" cint=v*10.0**scale-refv !} !{ caso seja uma variavel ascII nao permite que codigos asc <32 ! seja usados IF ((d%I>0).and.(CINT<32)) CINT=32 !} END function !-------------------------------------------------------------------------------! ! FUNCAO PRIVATIVA INTEIRA : MBUFR.NUMBITS_VINT | SHSF ! ! ------------------------------------------------------------------------------! ! Esta funcao e utilizada na "bufrizacao" de dados compactados ! ! Retorna o numero de bits necessarios para representar um valor inteiro positivo ! Retorna zero se o valor for zero ou negativo ! ! ! Obs.: Inverso a vint_numbits (vide VINT_NUMBITS) !-------------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! !-------------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_______________________________________________________________________________! function numbits_vint (v);INTEGER:: numbits_vint INTEGER,intent(in)::v ! Um Numero Inteiro INTEGER::numbits,v2 IF (v>0) THEN numbits=1 v2=v do while (v2>1) v2=v2/2 numbits=numbits+1 END do ELSE numbits=0 END IF numbits_vint=numbits END function numbits_vint !} !-------------------------------------------------------------------------------! ! FUNCAO PRIVATIVA INTEIRA : MBUFR.VINT_NUMBITS | SHSF! ! ------------------------------------------------------------------------------! ! Esta funcao e utilizada para determinar valores "missing" em BUFR ! ! Retorna o maximo valor inteiro positivo representado por um determinado ! numero de bits ! Se o numero de bits for igual ou menor que zero, retorna o valor zero ! ! Obs.: Inverso a vint_numbits (vide NUMBITS_VINT) !-------------------------------------------------------------------------------! ! Chamadas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! !-------------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_______________________________________________________________________________! ! vint_numbits !{ function vmax_numbits(nbits);INTEGER::vmax_numbits INTEGER,intent(in)::nbits INTEGER:: i,valmax valmax=0 i=0 do i=1,nbits valmax=valmax+2**(i-1) END do vmax_numbits=valmax END function vmax_numbits !-------------------------------------------------------------------------------! ! SUBROTINA PRIVATIVA : INIT_ERROMESSAGE | SHSF ! ! ------------------------------------------------------------------------------! ! DEFINE AS MENSAGENS DE ERRO APRESENTADAS PELAS DIVERSAS ROTINAS DESTE MODULO ! !-------------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! SUBROUTINE INIT_ERROMESSAGE ERROMESSAGE(:)="" ERROMESSAGE(14)="Master Table upgrade is necessary" ERROMESSAGE(15)="Divergence Between provided descriptors and variables" ERROMESSAGE(30)="Section3 corrupted" ERROMESSAGE(15)="Local BUFR table not found" ERROMESSAGE(41)="Read past section 4 limit" ERROMESSAGE(51)="Invalid Table C Descriptor" ERROMESSAGE(52)="Invalid Table B Descriptor" ERROMESSAGE(53)="Invalid Descriptor" ERROMESSAGE(54)="Expanded descriptors list is too big" ERROMESSAGE(55)="Erro in table D " ERROMESSAGE(61)="Error in Delayed replicator factor in Section 4" END SUBROUTINE INIT_ERROMESSAGE END MODULE