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 ! 20070324 -V1.6- SHSF - Corrigido teste de erro na leitura da secao 3 ( antes saia sem desalocar memoria) ! 20070416 -V1.7- SHSF - Corrigido funcao bits_tabb para que retorne zero ao receber descritor da tabela C ! 20070603 -V1.8- SHSF - Acrescentado verificacao de "\" ou "/" na variavel de ambiente MBUFR_TABLES; ! acrescido inicializacao de sec4%c(:,:)=0 antes da leitura da secao 4. ! 20070922 -V2.0 SHSF - Atualizacao da secao 1 para leitura do BUFR EDICAO 4. Acrescentado teste em READ_MBUFR ! Para tratamento do replicador posposto com BUFR comprimido. Tambm introduzido remocao ! de descritores quando o fator de replicao zero, para o caso da leitura em modo ! comprimido. Falta fazer o mesmo nos outros modos e tambm na gravao. Feito um ! paleativo para evitar erro de leitura em modo comprimido, quando tem dados do tipo ! caracter. ! 20071019 -V2.1 SHSF Feito modificacao na subrotinas de reinicializacao da tabelas BUFR e inserido o tratamento ! do fator de replicacao ZERO em readsec4rd - Falta comparar resultados ! 20071113 _V2.2 SHSF a) Criado nova subrotina (remove_desc) para remocao de descritores, para ser usada com replicadores zero ! Em readsec4cmp e readsec4_rd. ! b) Readsec4cmp foi modificado para passar a aceitar erro de leitura de -12 bits ! devido a erros na leitura de dados de boias. Necessario verificar se o erro esta nos ! arquivos de boias do ARGOS ou se e algum detalhe neste programa. Nota: Este erro ocorre ! nos casos de BUFR compactato + replicador posposto+variaveis catacteres ! c) Modificado subrotina de expanso de subdescritores para melhor adequar ao sistema, principalmente ! quando envolve replicadores pos-postos. Quando ocorre replicadores pos-postos, o subotina de expansao ! de descritores e rodada varias vezes, incluindo a parte de subdescritores. Contudo a subrotina de ! de subdescritores nao podia ser rodada mais de uma ves, pois isto geraria criacao de subdescritores ! que de fato nao existiam. Com a modificacao implementada, somentes as variaveis caracteres que nao ! foram convertidas em subdescritores anteriormente serao convertidas na chamada. ! Nota: Tais modificacoes foram testadas na leitura. Para a gravacao de BUFR a gravacao simultanea de ! replicadores pos-postos no modo compactado ficam proibidos ! 20080104 V2.3 SHSF Corrigido BUG na rotina readsec4cmp no controle do loop de descritores ! 20080118 V2.4 SHSF Modificado leitura da tabela B para detectar eventuais erros de formatacao da mesma. ! 20080122 V2.5 SHSF Modificado CINT e CVAL para tratar valor null. Modificado READSEC4CMP para fazer consistencia do valor minimo ! e do contador de bits na leitura compactada ! 20080129 V2.6 SHSF Corrigido readsec4rd.estava repetindo a leitura do primeiro subset ! 20080201 V3.0 SHSF Corrigido problema de imprecisao na conversao de numeros reais para inteiros ! Foi modificado a funcao CINT, com a inclusao da aproximacao de 0.5 na conversao de inteiros ! 20080308 V3.1 SHSF Modificado CINT para tratar valores negativos ! 20080417 V3.2 SHSF Revisao da gravacao da secao 1 savesec1 e da indicacao da gravacao da secao 2 ! 20080619 V3.3 SHSF Introduzido redutor de numero de descritores maximos (ndescmax) em read_mbufr para o caso ! de arquivos sem descritores replicadores ! 20080620 V4.b SHSF Corrigido e atualizado gravacao da secao 1, que agora pode gravar a secao 3 ou 4 ! Mudado open_mbufr para considear a edicao 4 como edicao padrao de gravacao ! 20080804 V4.0 SHSF Modificacao do check_table a reinittable para desvinculacao da versao 14 da tabelas mestres anteriores ! e para considerar tabelas mestres diferentes de zero !-------------------------------------------------------------------------------------------------- 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 :: intbsubtype INTEGER :: center INTEGER :: subcenter INTEGER :: update INTEGER :: year INTEGER :: month INTEGER :: day INTEGER :: hour INTEGER :: minute INTEGER :: second INTEGER :: NumMasterTable INTEGER :: VerMasterTable INTEGER :: VerLocalTable 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 Mestre INTEGER::nummastertab !......................................Numero da tabela Mestre INTEGER::Init_centre_mbufr !.......................Codigo do Centro que gerou o BUFR INTEGER::Init_verloctab !.....................................Versao da tabela local INTEGER::Init_vermastertab !.................................Versao da tabela Mestre INTEGER::Init_nummastertab !.................................Numero da tabela Mestre 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 integer::is_cpk !} !{ 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,VMasterTable,VLocalTable,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)::VMasterTable INTEGER,intent(in)::VLocalTable INTEGER,optional,intent(in)::BUFRED !......................EDICAO BUFR !} !{ Variaveis locais INTEGER::uni !................................Variaavel auxiliar de UN INTEGER::i !} uni=un VerMasterTab=VMasterTable VerLocTab=VLocalTable NumMasterTab=0 centre_mbufr=centre Init_VerMasterTab=VerMasterTab Init_VerLocTab=VerLocTab Init_centre_mbufr=centre_mbufr Init_NumMasterTab=NumMasterTab currentRG=0 NMSG=0 is_cpk=0 ! Este e uma bandeira que quando 1 indica que um BUFR compactado ! e ao mesmo tempo indica para nao processar subdescritores na ! leitura (isto provisorio ate ter uma solucao para variaveis ! caracteres compactados IF (present(BUFRED)) THEN BUFR_Edition=BUFRED ELSE BUFR_Edition=4 END IF print *,"" print *,"+-----------+----------------------------------------+" print *,"| MBUFR-ADT | Module to encode and decode FM-94 BUFR |" Print *,"| | SHSF - VERSION 4.0 04.09.2008 |" print *,"+-----------+----------------------------------------+" call getenv("MBUFR_TABLES",local_tables) !{ Acrescenta barra no final do diretorio local_tables, caso seja necessario ! Nesse processo veirifica se o diretorio contem barras do windows ou barra do linux i=len_trim(local_tables) if ((local_tables(i:i)/="\").and.(local_tables(i:i)/="/")) then if (index(local_tables,"\")>0) then local_tables=trim(local_tables)//"\" else local_tables=trim(local_tables)//"/" end if end if call INIT_TABB(Uni) ! Carrega tabela BUFR em TABB call INIT_TABD(Uni) ! Carrega tabela BUFR em TABD call INIT_ERROMESSAGE print *, " " write( *,'(" MBUFR-ADT: OPEN ",A, " AS #",I2)')trim(filename), 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 !{ INTEGER Tam_BUFR !-Tamanho total do arquivo BUFR (grav. na secao 1) INTEGER Tam_sec1 !-Numero de bytes da 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 :: 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 ndxmax=sec4%nvars*2 ndesc_sec4=0 delayed_rep=.false. allocate(SEC4%d(1:ndxmax,1:sec3%nsubsets),STAT=ERR) allocate(desc_sec3(1:sec3%ndesc),STAT=aerr) IF(aerr>0) THEN print *,"Erro in the memory alocation for secao 3" stop END IF allocate(desc_sec4(1:ndxmax),STAT=aerr) IF(aerr>0) THEN print *,"Erro in the memory alocation for 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 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 *,"Warning ! Using uncompressed bufr" sec3%is_cpk=0 END IF !} !{ Se IdObs for fornecido entao a secao 2 e utilizada IF (present(optsec)) THEN sec1%sec2present=.true. ELSE sec1%sec2present=.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,tam_sec1) !{ Salva a Secao 2 se savesec2_mbufr=.true. IF (sec1%sec2present) 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+tam_sec1+tam_sec2+Tam_sec3+Tam_sec4+4 NRG=RGF-RG0 IF (Tam_bufr/=NRG) THEN print *, "Erro in the SAVE_MBUFR subroutine" 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 *,"Error in"//TRIM(SUBNAME)//"_copy2oct !" PRINT *, "Possible error on the specification of variable n ",N print *, "Number of 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 ELSE PRINT *,"Error in "//TRIM(SUBNAME)//"_put_octets !" write(*,500)N,A_VAL(n),A_BITS(n) 500 FORMAT( " Variable(",I6.6,") Value =",I11," Number of bits = ",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) if (noct>ubound(oct,1)) then print *,"Error in "//TRIM(SUBNAME)//"_put_octets !" stop end if 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 in MBUFR"//SUBNAME print *, "Menssage too big. Size= ", Tam_BUFR print *, "Numeber of Menssage =",NMSG print *, "" close(uni) stop END IF IF (Tam_BUFR > 10000 ) THEN print *," Warning ! Size of message exceeded 10 KBytes " print *," Menssage =", NMSG print *," Size = ", 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 *,"Error in the section 0 especificatios: numeber of octets =",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,NUM_OCTETS) !{ Variaveis da Interface INTEGER, intent(in)::UN TYPE(sec1TYPE),intent(inout)::sec1e integer,intent(inout)::NUM_OCTETS !.....Numero de octetos (tamanho) da secao 1 !} !{ Variaveis locais CHARACTER(len=1),DIMENSION(24):: sec1 !..Para gravar secao 1 de ate 23 bytes INTEGER :: uni,noct,err,I INTEGER,DIMENSION(19)::A,B !.............Vetor de Valores e Numero de bits de cada valor INTEGER :: NUM_ELEMENTS ! ...............Numero de elementos em A() E B() !} uni=un SUBNAME="SAVESEC1" err=check_vertables(sec1e%center,sec1e%NumMasterTable,sec1e%VerMasterTable,sec1e%VerLocalTable) if (err>0) stop if (BUFR_EDITION<4) THEN !BUFR EDITION = 3 !------------------------------------------------------------------------------ !Bits | Values |Octet| Definitions !----------------------------------------------------------------------------- BUFR_EDITION=3 B(1)=24;A(1)=18 ! 1-3 |Lenght of section, in octets B(2)=8;A(2)=NumMasterTab ! 4 |Bufr Master Table number B(3)=8;A(3)=sec1e%subcenter ! 5 |Originating/generating sub-centre B(4)=8;A(4)=sec1e%center ! 6 |Originating/generating centre B(5)=8;A(5)=sec1e%update ! 7 |Update sequence number 0 for original BUFR messages IF (sec1e%sec2present) THEN !-----| B(6)=1; A(6)=1 ! 8 | bit1 =0 No optional secion =1 Optional section included ELSE ! | B(6)=1; A(6)=0 ! | END IF ! | B(7)=7; A(7)=0 ! | Bits 2-8 set zero (reservate) !-----| B(8)=8; A(8)=sec1e%bTYPE ! 9 | Data category TYPE (BUFR Table A) (Byte 9) B(9)=8; A(9)=sec1e%bsubTYPE ! 10 | Data sub-category (Defined by local ADP centres) B(10)=8;A(10)=VerMasterTab ! 11 | Version Number of master table B(11)=8;A(11)=VerLocTab ! 12 | Vertion number of local table B(12)=8 !-----| IF (sec1e%year<=2000) THEN ! 13 | Year of century A(12)= sec1e%year - 1900 ! | ELSE ! | A(12)=sec1e%year - 2000 ! | END IF !-----| B(13)=8; A(13)= sec1e%month ! 14 | Month B(14)=8; A(14)= sec1e%day ! 15 | Day B(15)=8; A(15)= sec1e%hour ! 16 | Hour B(16)=8; A(16)= sec1e%minute ! 17 | Minute B(17)=8; A(17)= 0 ! 18 | Reservado for local use by ADP centres NUM_ELEMENTS=17 NUM_OCTETS=18 A(1)=NUM_OCTETS ELSE !BUFR EDITION = 4 !------------------------------------------------------------------------------ !Bits | Values |Octet| Definitions !----------------------------------------------------------------------------- BUFR_EDITION=4 B(1)=24;A(1)=24 ! 1-3 |Lenght of section, in octets B(2)=8; A(2)=NumMasterTab ! 4 |Bufr Master Table number B(3)=16;A(3)=sec1e%center ! 5-6 |Originating/generating center B(4)=16;A(4)=sec1e%subcenter ! 7-8 |Originating/generating subcenter B(5)=8; A(5)=sec1e%update ! 9 |Update sequence number 0 for original BUFR messages IF (sec1e%sec2present) THEN !-----| B(6)=1; A(6)=1 ! 10 | bit1 =0 No optional secion =1 Optional section included ELSE ! | B(6)=1; A(6)=0 ! | END IF ! | B(7)=7; A(7)=0 ! | Bits 2-8 set zero (reservate) !-----| B(8)=8; A(8)=sec1e%bTYPE ! 11 | Data category TYPE (BUFR Table A) (Byte 9) B(9)=8;A(9)=sec1e%intbsubTYPE ! 12 | Data sub-category (Defined by local ADP centres) B(10)=8; A(10)= sec1e%bsubTYPE ! 13 | Data sub-category local (defined locally by automatic data processing centres) B(11)=8;A(11)= VerMasterTab ! 14 | Version Number of master table B(12)=8;A(12)= VerLocTab ! 15 | Vertion number of local table B(13)=16;A(13)= sec1e%year !16-17| Year B(14)=8; A(14)= sec1e%month ! 18 | Month B(15)=8; A(15)= sec1e%day ! 19 | Day B(16)=8; A(16)= sec1e%hour ! 20 | Hour B(17)=8; A(17)= sec1e%minute ! 21 | Minute B(18)=8; A(18)= sec1e%second ! 22 | Second B(19)=16; A(19)= 0 !23-24| Reservado for local use by ADP centres NUM_ELEMENTS=19 NUM_OCTETS=24 A(1)=NUM_OCTETS END IF ! Organiza os dados da secao 1 em octetos (sec1) !{ call PUT_OCTETS(A,B,NUM_ELEMENTS,sec1,noct,err) IF ((noct/=NUM_OCTETS).or.(err/=0)) THEN print *,"Error in the secion 1 especification: numeber of octets =",noct stop END IF !} !Grava os byte da secao 1 (SHSF) !{ do i=1,NUM_OCTETS 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 writing section 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 in the section 3: number of octets =",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 in the section 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 passadas na secao 3 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*2+5)*4))::A,B ! Vetor de Valores e Numero de bits de cada valor CHARACTER(len=1),DIMENSION((nsubset*nvarmax*2+5)*16):: sec4 CHARACTER(len=1),DIMENSION(4)::auxsec4 INTEGER :: uni,k,err,noct,noctaux,j,i INTEGER :: nvarlimit ! Numero variaveis limite durante o processo de codificacao ! Nota: Dutante a codificacao com replicador pospost pode ser necessario um numero de variaveis ! maior do que o fornecido. Isto ocorre quando e utilizado fator de replicacao nulo. ! Para evitar problemas de fata de alocacao de espaco, definiu-se nvarlimit duas vezes maior do ! que nvarmax !} uni=un SUBNAME="SAVESEC4RD" ! Nota: Dutante a codificacao com replicador pospost pode ser necessario um numero de variaveis ! maior do que o fornecido. Isto ocorre quando e utilizado fator de replicacao nulo. ! Para evitar problemas de fata de alocacao de espaco, definiu-se nvarlimit duas vezes maior do ! que nvarmax { nvarlimit=nvarmax*2 !} allocate(D(1:nvarlimit),STAT=err) IF(err>0) THEN print *,"Error allocating memory for section 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,nvarlimit,D,ndesc_sec4,IFinal,err) if(err>0) return 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 in section 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,ii,jj 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 !{ Verifica caracteres incorretos na tabela B jj=0 DO II=1,LEN_TRIM(A(1:118)) IF (ICHAR(A(II:II))==9) then A(II:II)="?" jj=1 END IF if (ICHAR(A(II:II))<32) A(II:II)=" " END DO if (jj>0) then print *,"Erro reading BUFR TABLE B" print *, "Tabulation code found at line:" print *,trim(A) stop end if !} IF (len_trim(a)>117) 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 reading BUFR table " print *,"Line=",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 else print *,"Erro reading BUFR TABLE B near line",i print *,trim(A) stop 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 ! IF ((x==2).and.(y==36)) then ! print *, TABD(F,X,Y,l) ! print *,l ! end if goto 888 9898 continue END SUBROUTINE INIT_TABD ! ----------------------------------------------------------------------------! ! SUBROUTINE PRIVADA: MBUFR.REINITTABLES | SHSF! ! ----------------------------------------------------------------------------! ! Reinicializa tabelas BUFR (utilizando diferentes versoes) ! ! ! ! ----------------------------------------------------------------------------! ! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:INIT_TABB,INIT_TABD ! ! ----------------------------------------------------------------------------! ! HISTORICO: ! ! Versao Original: Sergio H. S. Ferreira ! !_____________________________________________________________________________! SUBROUTINE REINITTABLES(Center,NMT,VMT,VLT,Err) !{ Variaveis de interface INTEGER,intent(in) :: center INTEGER, intent(in) :: NMT INTEGER, intent(in) :: VMT INTEGER,intent(in):: VLT INTEGER, intent(out) :: err !} !{ Variaveis locais CHARACTER(len=255):: tabb_filename,tabd_filename LOGICAL :: exists !} write(tabb_filename,14)NMT,center,VMT,VLT 14 format("B",i3.3,i3.3,2i2.2,".txt") write(tabd_filename,15)NMT,center,VMT,VLT 15 format("D"I3.3,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 NumMasterTab=NMT VerMasterTab=VMT VerLocTab=VLT 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 if (NOCT2<0) return !} !{ 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: Unexpected number of bits" 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 ]c3 ! ! ----------------------------------------------------------------------------! 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 type(descbufr)::auxdesc ! Variavel auxiliar do tipo descbufr INTEGER :: ndescmax INTEGER :: tam_sec3, tam_sec3max INTEGER :: tam_sec4, tam_sec4max integer :: tam_sec1 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,RGSEC4,ERR,errcmp,errrd ,j INTEGER :: tam_sec2 INTEGER :: IFinal INTEGER :: alerr INTEGER :: nvars integer,parameter::currentRGMax=2100000000 integer::Fator_replicacao logical::Delayed_Replicator !} !{ 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 delayed_Replicator=.false. 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 *, "Error in the READ_mbufr (memory allocation)" print *, "pointer desc_sec4(ndmax)" print *, "ndmax=",ndmax errsec=99 return END IF desc_sec4(1:ndmax)%i=0 sec3%ndesc=0 sec4%nvars=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) BUFR_EDITION=BUFR_ED !'}------------------------------------------------------------------------- !'{ VerIFica se a edicao BUFR ee suportada por esta rotina IF ((bUFR_ED < 2).Or.( bUFR_ED > 4)) THEN print *, "**** Warning ****" PRINT *,"This program was prepared to read BUFR edition 2, 3 and 4" print *,"Other edition cam be read in incorrectly way" PRINT *,"" END IF !'}------------------------------------------------------------------------- !'{ VerIFica O FINAL DA MENSAGEM. Se passar por este teste esta !' mesagem possui o tamanho correto. ! Nota: Pode ocorrer erro caso o tamanho do arquivo for menor que a posicao do ! 7777 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,tam_sec1,err) IF (err/=0) THEN errsec=err print *,"Erro ",errsec,"! ",trim(ERROMESSAGE(err)) 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 reading setion2" 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 ! { write(*,'(" Error ",i2,": ",a)')err,trim(erromessage(err)) errsec=err goto 99 !} END IF !} 60 continue !{ Processa a expancao dos descritors IFinal=0 is_cpk=sec3%is_cpk call expanddesc3(desc_sec3,sec3%ndesc,ndescmax,desc_sec4,nvars,IFinal,err) 70 IF (err/=0) THEN errsec=err+50 goto 99 END IF !} !------------------------------------------------------------ ! Reducao do ndescmax ! Caso nao haja repricador posposto nao existe a necessidade ! de usar um ndescmax previamente estabelecido. Neste caso ! e usado o ndescmax e reduzido para um numero de descritores ! que realmente existem na mensagem BUFR !------------------------------------------------------------ !{ if (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 !} !-------------! ! 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,tam_sec1,sec1err) !{ Declaracao de variaveis da interface INTEGER,intent(in)::un TYPE(sec1TYPE),intent(out)::sec1e integer,intent(inout)::tam_sec1 INTEGER,intent(inout)::sec1err !} !{ Declaracao de variaveis locais CHARACTER(len=1):: sec1(30) INTEGER,DIMENSION(20) :: b, a INTEGER :: i,err !} !{ Inicializar variaveis A(1:20)=0 sec1err=0 SUBNAME="READSEC1" !'{ Ler os 3 primeiros octetos da secao 1 do i = 1,3 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 Call GET_OCTETS(sec1, 3, b, a, 1,0, ERR) tam_sec1=a(1) if (tam_sec1==0) then print*,"Erro leitura secao1" sec1err=11 return end if !'{ Ler octetos da secao 1 do i = 4,tam_sec1 currentRG = currentRG + 1 IF (IOERR(UN)==0) read(un,rec= currentRG) sec1(i) IF (IOERR(UN)/=0) RETURN END do !'} IF (BUFR_EDITION<4) THEN !'{ Obter valores de cada um dos octetos lidos SECAO 1 EDICAO 2 E 3 !------------------------------------------------------------------ !Num. Bits | Descrio |Octeto !----------------------------------------------------------------- b(1) = 24 !'Tan_sec1 = Tamanho da secao 1................| 1-3 b(2) = 8 !'BUFR Master Table Se 0 ee a tabela padrao ...| 4 b(3) = 8 !'Sub centro gerador...........................| 5 b(4) = 8 !'Centro gerador...............................| 6 b(5) = 8 !'Numero da Atualizacao........................| 7 b(6) = 1 !'secao 2 incluida.............................| 8 b(7) = 7 !' Tudo Zero...................................| 8 b(8) = 8 !' Categora dos dados .........................| 9 b(9) = 8 !' sub-categoria dos dados.....................| 10 b(10) = 8 !' Versao da tabela mestre usada...............| 11 b(11) = 8 !' versao da tabela local usada................| 12 b(12) = 8 !' Ano do seculo...............................| 13 b(13) = 8 !' MES.........................................| 14 b(14) = 8 !'DIA..........................................| 15 b(15) = 8 !'hORA.........................................| 16 b(16) = 8 !'minuto.......................................| 17 Call GET_OCTETS(sec1, tam_sec1, 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 in section 1" sec1err=12 return END IF sec1e%subcenter=A(3) sec1e%center = a(4) sec1e%update=a(5) IF (a(6) == 1) then sec1e%sec2present = .True. else sec1e%sec2present = .false. end if sec1e%bTYPE = a(8) sec1e%bsubTYPE = a(9) sec1e%NumMasterTable=a(2) sec1e%VerMasterTable=a(10) sec1e%VerLocalTable=a(11) sec1e%year = a(12) sec1e%month = a(13) sec1e%day = a(14) sec1e%hour = a(15) sec1e%minute = a(16) sec1e%Intbsubtype=0 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 ELSE ! BUFR EDITION 4 !------------------------------------------------------------ ! Bits |Octet| Definicoes !------------------------------------------------------------ b(1) = 24 ! 1-3 |Tan_sec1 = Tamanho da secao 1 b(2) = 8 ! 4 |BUFR Master Table Se 0 ee a tabela padrao b(3) = 16 !5-6 |Identification of originating/generating centre (see Common Code Table C-11) b(4) = 16 !7-8 |Identification of originating/generating sub-centre (allocated by originating/generating Centre- see Common Code Table C-12) b(5) = 8 ! 9 |Update sequence number (zero for original BUFR messages; incremented for updates) b(6) = 1 !10 |Bit 1 =0 No optional section =1 Optional section follows b(7) = 7 ! |Bit 2-8 Set to zero (reserved) b(8) = 8 !11 |Data Category (Table A) b(9) = 8 !12 |Data sub-category international (see Common Code Table C-13) b(10)= 8 !13 |Data sub-category local (defined locally by automatic data processing centres) b(11)= 8 !14 |Version number of master table (currently 12 for WMO FM 94 BUFR tables - see Note (2)) b(12)= 8 !15 |Version number of local tables used to augment master table in use - see Note (2) b(13)= 16 !16-17|Year (4 digits) | b(14)= 8 !18 |Month | b(15)= 8 !19 |Day | Most typical for the BUFR message content b(16)= 8 !20 |Hour | b(17)= 8 !21 |Minute | b(18)= 8 !22 |Second | b(19)= 8 !23 |Reserved for local use by ADP centres Call GET_OCTETS(sec1, tam_sec1, b, a, 19,0, ERR) IF (ERR < 0) THEN print*,"Error reading section 1" sec1err=11 return END IF IF (a(1) /= 24) THEN print *,"Erro reading section 1 " sec1err=12 return END IF sec1e%center = a(3) sec1e%subcenter=A(4) sec1e%update=a(5) IF (a(6) == 1) then sec1e%sec2present = .True. else sec1e%sec2present = .false. end if sec1e%bTYPE = a(8) sec1e%IntbsubTYPE = a(9) sec1e%bsubtype=a(10) sec1e%NumMasterTable=a(2) sec1e%VerMasterTable=a(11) sec1e%VerLocalTable=a(12) sec1e%year = a(13) sec1e%month = a(14) sec1e%day = a(15) sec1e%hour = a(16) sec1e%minute = a(17) 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 END IF sec1err=check_vertables(sec1e%center,sec1e%NumMasterTable,sec1e%VerMasterTable,sec1e%VerLocalTable) 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 mestre desta esatualizada ! ! 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,NMT,VMT,VLT) INTEGER :: check_vertables !{ Variaveis da Interface INTEGER,intent(inout)::center INTEGER,intent(inout)::NMT ! Number of Master Table (for checking) INTEGER,intent(inout)::VMT ! Version of Master Table (for checking) INTEGER,intent(inout)::VLT ! Version of Local Table (For checking) INTEGER:: err !} !{ Variaveis locais logical::reinittab ! true = Tabela incompativel. Reinicializa tabelas !} reinittab=.false. !{ Verifica se e uma tabela mestre diferente If ((NMT/=NumMasterTab)) then reinittab=.true. end if !} !{ Verifica se a versao da tabela mestre esta desatualizada. if (VerMasterTab13. IF ((VMT>13).or.(VerMastertab>13)) THEN IF((VerMastertab/=VMT)) reinittab=.true. end if !} !{ Verifica se e uma tabela local IF ((VLT>0).or.(VerLoctab>0)) THEN IF(VerLoctab/=VLT) reinittab=.true. IF(center/=centre_mbufr) reinittab=.true. if(VerMasterTab/=VMT) reinittab=.true. end if !{ Reinicia tabela se necessario check_vertables=0 if (reinittab) then call reinittables(Center,NMT,VMT,VLT,err) IF (err>0) THEN print *,"Erro 14! ",ERROMESSAGE(14) print *,"It's Necessary MASTER TABLE=",NMT print *,"Version of Master Table=",VMT print *,"Version of Local Table=", VLT print *,"Center=",center check_vertables=14 end if END IF 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 *,"Error in section 2" 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 *,"Error during memory allocation for section 3 (D)" stop END IF allocate(sec3b(1:tam_sec3),stat=aerr) IF(aerr>0) THEN print *,"Error during memory allocation for section 3 (sec3b)" stop END IF deallocate(sec3e%d) allocate(sec3e%d(1:ndesc),STAT=aerr) IF(aerr>0) THEN print *,"Error during memory allocation for section 3 (sec3e)" stop END IF allocate(A(1:ndesc*4),B(1:ndesc*4),STAT=aerr) IF(aerr>0) THEN print *,"Error during memory allocation for section 3 (A,B)" 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 deallocate (a,b,sec3b) return END IF !} IF(sec3e%nsubsets<1) THEN ERR_sec3=32 deallocate (a,b,sec3b) 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 *,"Error during memory allocation for section 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 *, "Error during memory allocation for section 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),": Error during memory allocation" 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),": Error during memory allocation" 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 *,"Error during memory allocation (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 k=0 k0=k do i=1,nsubsets call tabc_setparm(err=err) 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) if (err>0) then deallocate(a,b,sec4,dx) errrd=err return end if l=0 IF (xx*8xx*8)) then print *,"Error reading sec4" deallocate (a,b,sec4,dx) return end if repdelayed%f=dx(l-1)%f repdelayed%x=dx(l-1)%x repdelayed%y=repfactor dx(l-1)=dx(l) dx(l)=repdelayed k=k0 !{Quando o Fator de Replicao igual a zero, entao ! elimina o replicador e os descritores replicados If (REPFACTOR==0)then call remove_desc(dx,nvars,ifinal,ifinal+dx(ifinal)%x) ifinal=1 ! Volta ao inicio ! para eliminacao end if goto 444 END IF ! Se chegou aqui e porque todos os replicadores pospostos ! do sub-conjunto i foram encontrados e convertidos em replicadores ! normais. Portanto, a partir deste ponto inicia-se a leitura ! dos dados !{ Zerando a estrutura de dados da secao 4 sec4e%d(:,i)=null !} !{ Decodificando valores kf=k k=k0 k0=kf j=0 do while (jnvars_maxsubset) nvars_maxsubset=IFinal sec4e%nvars=nvars_maxsubset !{ Numro bits q falta no final o subst !} Fim da decodIFicaccaao END do !} ! Fim da leitura da seccaao 4 800 deallocate(a,b,sec4,dx) SUBNAME="" 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 !} !{ Variaveis locais INTEGER,DIMENSION((nsubset*(ndesc+5)*5))::A,B ! Vetor de Valores e Numero de bits de cada valor CHARACTER(len=1),allocatable :: sec4(:) ! Valor anterior eh 28 CHARACTER(len=1),DIMENSION(4)::auxsec4 INTEGER :: uni ,k,err,j ,i ,nbytes,l INTEGER::xx,kmax,aerr INTEGER :: vmini ! Auxiliar para valor minimo (inteiro) INTEGER :: bbit ! Auxiliar para quantidade de bits compactos integer:: ndesc2 ! O mesmo que ndesc REAL :: VMINI2 integer::diff !} !{Iniciar variaveis e parametros uni=un SUBNAME="READSEC4CMP" errsec4=0 kmax=ubound(A,1) call tabc_setparm(err=err) !Inicial parametros da tabela C !} !------------------------------------------------------------------------------ !Obter tamanho da secao 4 !------------------------------------------------------------------------------ ! {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 !} !{Obter 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 !------------------------------------------------------------------------------ ! LER TODA A SECAO 4 !------------------------------------------------------------------------------ !{Alocando sec4 allocate(sec4(1:xx),stat=aerr) IF (aerr>0) THEN print *,"Error during memory allocation for section 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 dos 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 j=0 ndesc2=ndesc do while (j0)" print *,"Descriptor ",j,"codigo=",d(j)%f,d(j)%x,d(j)%y bbit=0 end if !} if (tabb(d(j)%f,d(j)%x,d(j)%y)%u==1) bbit=bbit*8 ! Caso seja variavel caracter entao converte bytes p/ bits VMINI2=CVAL(vmini,D(J)) diff=b(k-1)-bbit+tabc%dbits IF (diff<-1000) 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 *,"Warning! Compressed variable bigger than original variable (",d(j)%f*100000+d(j)%x*1000+d(j)%y,") Diff=",diff,"j=",j bbit=0 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 !{ Caso variavel caracter !Neste caso nao precisamos fazer a leitura !do valor minimo, pois os dados caracteres nao sao !comprimidos. No lugar do numero de bits e informado e o numero !de bytes, mas nao podemos calcular estes valores a partir do !da definicao do numero de bits do descritor ! ! Como trabalhos com subdescritores para variaveis caracteres ! O que fazemos e apenas atribuir os valores 8 a b(k) diretamente ! a cada subdescritor nbytes=tabb(d(j)%f,d(j)%x,d(j)%y)%nbits/8 do l=1,nbytes k=k+1; b(k)=8 end do j=j+nbytes-1 k=k+1; b(k)=6 Call GET_OCTETS(sec4, xx, b, a, k, K-nbytes,ERR) IF (ERR < 0) THEN errsec4=1 deallocate(sec4) return END IF if (a(k)/=nbytes) then errsec4=1 deallocate(sec4) return end if ! { Replicando o numero de bits para todos os ! sub-conjuntos do descritor j do i=1,nsubset do l=1, nbytes k=k+1 b(k)=8 end do END do end if 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 ! 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<-12) then errsec4=1 DEALLOCATE(SEC4) return end if err=0 !{ **** Descompactacaao ***** k=0 j=0 do while (j< ndesc2) j=j+1 if (d(j)%F==0) then IF (d(j)%i==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 !{ Caso seja variavel caracter !{ Salta o valor minimo k=k+1 nbytes=tabb(d(j)%f,d(j)%x,d(j)%y)%nbits/8 k=k+nbytes !} !{Salta valor correspondente ao numero de bits(bytes) if (a(k)/=nbytes) then stop end if !} !{Para todos os subsets sao obtidos todos os bytes do i=1,nsubset do l=j,nbytes+j-1 k=k+1 if ((a(k)<32).or.(a(k)>128)) a(k)=32 sec4e%r(l,i)=a(k) sec4e%d(l,i)=d(l)%f*100000+d(l)%x*1000+d(l)%y sec4e%c(l,i)=d(l)%i end do end do j=j+nbytes-1 !} ! end if 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 sao 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 !{ Salva os descritores no caso de ter havido erro de leitura if(ndesc20) then print *,"Erro em expanddesc3/replicdesc: chamada de ",trim(SUBNAME) I=iFINAL return end if IF (idelayed>0) 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) THEN print *,"Erro 54!",ERROMESSAGE(54) print *,"NDESCMAX=",k 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 !} !{ Atualiza idesc idesc=(jy*jx)-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 else err=0 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 = 8, 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) bits_tabb2=0 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 if (a<0) then ! (a==null) cval=null 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)/(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 real::auxcint real::scale real:: refv INTEGER :: err !} cint=0 IF (d%f/=0) THEN call tabc_setparm(d,err) return END IF !Caso o valor passado seja "null", retorna null IF (v==null) then cint=null 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" auxcint=((v*10.0**scale)-refv) if (auxcint>=0) then cint=int(auxcint+0.5) else cint=int(auxcint-0.5) end if !} !{ 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 : DESC_DELETE | SHSF ! ! ------------------------------------------------------------------------------! ! APAGA, DE DENTRO DO VETOR D, OS DESCRITORES dentro do interfalo p1 a p2 !-------------------------------------------------------------------------------! ! Chamdas Externas: Nao Ha ! ! Chamadas Internas:Nao Ha ! ! ! Obs.: Utilizar apeanas pare remocao de descritores apos replicador nulo !------------------------------------------------------------------------------- subroutine remove_desc(d,nd,p1,p2) !{ Variaveis de interface type(descbufr),dimension(:),intent(inout)::d ! matriz de descritores integer,intent(inout)::nd ! Numero de descritores em nd integer,intent(in)::p1 ! Posicao inicial para remocao integer,intent(in)::p2 ! Posicao final para remocao !} !{Variaveis Locais integer ::i,j type(descbufr),dimension(nd)::daux !} !{ !{ Assinala os descritores que serao removido com f=-1 do i=p1,p2 d(i)%f=-1 ! Este erro nao deve ocorre !if (d(i)%i>0) then ! print *,"Erro in remove_desc",i,d(i)%i !end if end do !} !{ Copia os descritores para matriz auxiliar, sem os descritores ! assinalados j=0 do i=1,nd if (d(i)%f>=0) then j=j+1 daux(j)=d(i) end if end do nd=j !{ Copia de volta os descritores para a matriz inicial do i=1,nd d(i)=daux(i) end do end subroutine remove_desc !-------------------------------------------------------------------------------! ! 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(11)="Error in Section1" ERROMESSAGE(12)="Error in Section1" ERROMESSAGE(14)="Erro reading Bufr Tables" ERROMESSAGE(30)="Error in section3" ERROMESSAGE(31)="Error in Section3" ERROMESSAGE(32)="Error in Section3" 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 the section 4 or in the BUFR tables" ERROMESSAGE(62)="Error in the section 4 or in the BUFR tables" ERROMESSAGE(63)="Error in the section 4 or in the BUFR tables" END SUBROUTINE INIT_ERROMESSAGE !****************************************************************************** ! sep_char | Separa as palavras que compoe uma linha de texto | SHSF | !****************************************************************************** ! | ! Separa as pavras de uma linha de texto em uma matriz de palavras, | ! | !****************************************************************************** subroutine sep_char(string,words,nwords) !{ Variaveis da Interface character (len=*), intent (in) :: string !..................Texto de entrada character (len=*), dimension(:), intent (out)::words !..... Palavras separadas do texto integer , intent (out) :: nwords !..........................Numero de palavras !} !{ Variaveis Locais integer :: i,l,maxl,F character(len=1) ::D character(len=256) :: S !} F=0 S="" words(:)="" maxl=size(words,1) if (maxl<=2) goto 100 l=len_trim(string) if (l==0) goto 100 do i=1,l D = string(i:i) If (ichar(D)<33) Then If (Len(trim(S)) > 0) Then F = F + 1 words(F) = S S = "" End If Else S = TRIM(S) // D End If if (F==maxl+1) exit end do !i If (S /= "") F = F + 1; words(F) = S; S = "" 100 nwords=F End Subroutine END MODULE