!****************************************************************************** !* STRINGFLIB * !* * !* Biblioteca de funcoes e rotinas para manipulacao de variaveis-texto * !* * !* Copyright (C) 2005, Sergio Henrique Soares Ferreira * !* * !* MCT-INPE-CPTEC, Cachoeira Paulista, Brasil * !****************************************************************************** !* * !* Esta biblioteca fornece um conjunto de subrotinas e funcoes uteis para * !* manipulacao de variaveis-texto (Character) em FORTRAN * !* * !****************************************************************************** !* DEPENDENCIAS: GetArgs (Sistema Operacional) * !****************************************************************************** ! HISTORICO ! !2005-03-10 - SHSF - Corrigido "bug" na funcao str_real que ocorre quando passado ! o valor 0.0000E+00 ! !2007-01-20 - SHSF - Acrescido Subrotina GETARGS2 !2007-03-22 - SHSF - Modificacao da rotina VAL- Antiga VAL agora esta como VAL2 module stringflib ! USE MSFLIB ! Para compilacao em Windows ( Microsoft Power Station ) Real,parameter :: Null=-340282300 !valor nulo ou indefinido !****************************************************************************** ! STRS| Converte uma valiavel numerica em variavel texto (string) | SHSF | !****************************************************************************** ! | ! Esta e uma interface para converter variaveis numericas (INTERGER ou REAL) | ! em texto | !****************************************************************************** !{ private str_intS ! Converte INTEGER em CHARACTER private str_realS ! Converte REAL em CHARACTER interface STRS module procedure str_intS module procedure str_realS end interface !} !=========================================================================== contains !****************************************************************************** ! Sep_NatNum | Separacao de Numeros Naturais | SHSF | !****************************************************************************** ! ! ! Esta subrotina separa numeros naturais contidos em um texto uma variavel ! ! | !****************************************************************************** Subroutine Sep_NatNum(string, substrings, nelements) !{ Variaveis da Interface character(len=*), intent (in) :: string !.................. Texto de entrada contendo Letras e Numeros character(len=*), dimension(:), intent (out)::substrings !.Matriz contendo apenas os numeros que foram separados integer , intent (out) :: nelements !..................... Numero de elementos em "substrings" !} !{ Variaveis Locais integer :: i,l,maxl,F character(len=1) ::DS character(len=256) :: SS !} F=0 SS="" substrings="" maxl=size(substrings,1) l = Len_trim(string) if (l==0) goto 100 do i = 1,l dS = string(i:i) If (index("0123456789", dS)== 0) Then If (Len_trim(sS) > 0) Then F = F + 1 substrings(F) = trim(sS) sS = "" End If Else sS = trim(sS) // dS End If if (F==maxl+1) exit end do !i If (sS /="") then ;F = F + 1; substrings(F) = sS; sS = "";end if 100 nelements=F End Subroutine Sep_NatNum !****************************************************************************** ! Sep_NatNum | Separacao de Numeros Naturais | SHSF | !****************************************************************************** ! ! ! Esta subrotina separa numeros naturais contidos em um texto uma variavel ! ! | !****************************************************************************** Subroutine Sep_Num(string, substrings, nelements) !{ Variaveis da Interface character(len=*), intent (in) :: string !.................. Texto de entrada contendo Letras e Numeros character(len=*), dimension(:), intent (out)::substrings !.Matriz contendo apenas os numeros que foram separados integer , intent (out) :: nelements !..................... Numero de elementos em "substrings" !} !{ Variaveis Locais integer :: i,l,maxl,F character(len=1) ::DS character(len=256) :: SS !} F=0 SS="" substrings="" maxl=size(substrings,1) l = Len_trim(string) if (l==0) goto 100 do i = 1,l dS = string(i:i) If (index("-0123456789.+", dS)== 0) Then If (Len_trim(sS) > 0) Then F = F + 1 substrings(F) = trim(sS) sS = "" End If Else sS = trim(sS) // dS End If if (F==maxl+1) exit end do !i If (sS /="") then ;F = F + 1; substrings(F) = sS; sS = "";end if 100 nelements=F End Subroutine Sep_Num !****************************************************************************** ! sep_substrings| Separacao de "Strings" em "Sub-String" | SHSF | !****************************************************************************** ! | ! Decompoe um string em um conjunto e sub-strings segundo um caracter de | ! separacao. | ! | !****************************************************************************** subroutine sep_substrings(string,sep,substrings,nelements) !{Variaveis da Interface character (len=*), intent (in) :: string !....................Texto de entrada character (len=1), intent (in) :: sep !....................Caracter de separacao character (len=*), dimension(:), intent (out)::substrings !...Matriz dos subtextos obtidos integer , intent (out) :: nelements !.........................Numero de subtextos em substring !} !{ Variaveis Locais integer :: i,l,maxl,F,SLEN character(len=1) ::D character(len=256) :: S !} F=0 S="";SLEN=0 substrings="" maxl=size(substrings,1) if (maxl<=2) goto 100 l=len(trim(string)) if (l==0) goto 100 do i=1,l D = string(i:i) If ((D == sep)) Then F = F + 1 substrings(F) = S S = "";SLEN=0 Else SLEN=SLEN+1 S(SLEN:SLEN)=D(1:1) End If if (F==maxl+1) exit end do !i If (SLEN /= 0) F = F + 1; substrings(F) = S; S = "";SLEN=0 100 nelements=F End Subroutine sep_substrings !****************************************************************************** ! sep_words | 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_words(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 (index(" ,;",D)>0) 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 !****************************************************************************** ! str_ints | Converte uma variavel inteira em uma variavel-texto | SHSF | !****************************************************************************** ! Funcao tipo Character que converte o valor de uma variavel inteira nos | ! caracteres correspondentes | !****************************************************************************** function str_intS(a); character(len=256) ::str_intS !{ Variavel de Interface integer , intent (in) :: a !} !{ Variavel Local character(len=256)::b !} b="" write(b,*)a str_intS=adjustl(b) end function !****************************************************************************** ! str_reals | Converte uma variavel REAL em uma variavel-texto | SHSF | !****************************************************************************** ! Funcao tipo Character que converte o valor de uma variavel REAL nos | ! caracteres correspondentes | !****************************************************************************** function str_realS(a);character(len=256) ::str_realS,b !{ Variaveis da Interface real , intent (in) :: a !} !{ Variaveis Locais integer ::p,r !} b="" write(b,*)a b=adjustl(b) p=index(b,".") !{ Eliminando E+00 e E-00 r=INDEX(B,"E+00") IF (R>0) B=B(1:R-1) R=INDEX(B,"E-00") IF (R>0) B=B(1:R-1) !{Eliminando zeros a esquerda 11 r=len_trim(b) if ( (b(r:r)=="0").and.(r>p).and.(p/=0))then r=r-1 b=b(1:r) goto 11 end if !} if ((r==p).and.(p>0)) then r=r-1 b=b(1:r) end if str_realS=adjustl(b) end function !****************************************************************************** ! VAL | Converte CHARACTER em REAL | SHSF | !****************************************************************************** ! Funcao para converter texto com caracteres numericos em uma variavel | ! REAL. | ! | ! Caso a texto contiver caracteres invalidos VAL retornara o valor "NULL" | ! (Veja declaracao da variavel NULL) | ! | !****************************************************************************** function VAL2(AS);real VAL2 !{ Variaveis da interface character(LEN=*),intent (in) :: aS !} !{ Variaveis locais real ::b character(len=1):: cS character(len=255)::numS,aaS integer i,l,chknum !} chknum=1 numS="" aaS=adjustl(aS) l=len_trim(aaS) if (l>0) then do i=1,l cS=aaS(i:i) if (ichar(CS)<32) CS=" " if (index(" 0123456789.+-",cS)>0) then numS=trim(numS)//cS else chknum=0 end if end do if (chknum==1) then read(numS,*)b else b=NULL end if else b=NULL end if val2=b end function !****************************************************************************** ! VAL | Converte CHARACTER em REAL | SHSF | !****************************************************************************** ! Funcao para converter texto com caracteres numericos em uma variavel | ! REAL. | ! | ! Caso a texto contiver caracteres invalidos VAL retornara o valor "NULL" | ! (Veja declaracao da variavel NULL) | ! | !****************************************************************************** function VAL(AS);real VAL !{ Variaveis da interface character(LEN=*),intent (in) :: aS !} !{ Variaveis locais real ::b character(len=1):: cS character(len=255)::numS,aaS integer i,l,chknum !} chknum=0 numS="" aaS=adjustl(aS) l=len_trim(aaS) if (l>0) then do i=1,l cS=aaS(i:i) if (ichar(CS)<32) CS=" " if (index(" 0123456789.+-",cS)>0) then chknum=1 numS=trim(numS)//cS else exit end if end do if ((chknum==1).and.(len_trim(numS)>0)) then read(numS,*)b else b=NULL end if else b=NULL end if val=b end function !****************************************************************************** ! UCASES| Todos as letras MAIUSCULAS | SHSF | !****************************************************************************** ! Funcao que retorna um texto em "CAIXA ALTA" de um texto | ! | ! Exemplos: | ! char(97)="a" --> char(65)="A" | ! char(122)="z" --> char(90)="Z" | !****************************************************************************** function UCASES(str);character(len=255)::UCASES !{ Variaveis da interface character(len=*)::str !} !{ Variaveis locais character(len=255)::b integer :: i,l,a !} b=str l=len(trim(str)) if (l>0) then do i=1,l a=iachar(str(i:i)) if ((a>=97).and.(a<=122)) then a=a-32 b(i:i)=achar(a) end if end do end if ucaseS=b end function !****************************************************************************** ! LCASE| Todas as letras MENUSCULAS | SHSF | !****************************************************************************** ! Funcao que retorna um texto em "CAIXA BAIXA" de um texto | ! | ! Exemplos: | ! char(65)="A" --> char(97)="a" | ! char(90)="Z" --> char(122)="z" | !*****************************************************************************| function LCASES(str); character(len=255)::LCASES !{ Variaveis de Interface character(len=*)::str !} !{ Variaveis internas character(len=255)::b integer :: i,l,a !} b=str l=len(trim(str)) do i=1,l a=iachar(str(i:i)) if ((a>=65).and.(a<=90)) then a=a+32 b(i:i)=achar(a) end if end do lcaseS=b end function lcaseS !****************************************************************************** ! RIGHTS| Obtem os caracteres a direita de um texto | SHSF | !****************************************************************************** function rightS(char,lenth); character (len=lenth) :: rightS !{ Variaveis da interface character (len=*),intent (in) :: char !....................Texto original integer,intent (in):: lenth !..........comprimento do texto a ser obtido !} !{ Variaveis locais character (len=len(trim(char))):: a integer :: l,i !} a=trim(char) l=len(a) i=l-lenth+1 rightS=a(i:l) end function rightS !****************************************************************************** ! LEFTS| Obtem os caracteres a esquerda de um texto | SHSF | !****************************************************************************** function leftS(char,lenth); character (len=lenth) :: leftS !{ Variaveis de interface character (len=*),intent (in) :: char !....................Texto original integer, intent (in) :: lenth !..........comprimento do texto a ser obtido !} leftS=char(1:lenth) end function leftS !****************************************************************************** ! CUTSTRING| Corta um texto | SHSF | !****************************************************************************** ! Corta uma linha de texto a partir da primeira ocorrecia de um caracter ! especificado | !*****************************************************************************| subroutine CutString(line,char) !{ Variaveis de interface character(len=255),intent(inout)::line ! Linha de texto character(len=1),intent(in)::char ! Caracter para corte !} !{Variaveis locais integer :: cp !} cp=index(line,char)-1 if (cp>0) then line=line(1:cp) elseif(cp==0) then line="" end if end subroutine !****************************************************************************** !BETWEEN_INVCOMMAS| | SHSF | !****************************************************************************** !* Obtem a primeira ocorrencia de um texto delimitado por aspas duplas * !* * !****************************************************************************** function between_invdcommas (line); character(len=255)::between_invdcommas !{ Variaveis de interface character(len=*),intent(in)::line !} !{ Variaveis locais integer::i character(len=255)::auxline !} auxline=line between_invdcommas="" i=index(auxline,'"') if (i==0) return auxline=auxline(i+1:len_trim(auxline)) i=index(auxline,'"') if (i==0) return between_invdcommas='"'//auxline(1:i+1) end function !------------------------------------------------------------------------------ !GETARGS2 ! OBTEM ARGUMENTOS PASSADOS EM LINHA DE COMANDOS !SHSF ! ! ----------------------------------------------------------------------------- ! ESTA SUBROTINA E BASEADA NO COMANDO GETARG DO UNIX. ! ! ! ! Ao inves de obter os argumentos tal como sao digitados (getarg), esta ! ! sub-rotina interpreta as letras que precedidadas por "-" como indicativo ! ! do tipo de argumento que esta sendo passado ! ! ! ! ex.: programa -d 20APR2007 ! ! ! ! Neste exemplo "d" eŽ o nome do argumento e "20apt2007" eŽ o valor do ! ! argumento ! ! ! ! Programa Exemplo ! ! integer,paramenter::x= ! ! character(len=1),dimension(10)::namearg !........... Nome dos argumentos! ! character(len=20),dimension(10)::arg !...................... argumentos! ! integer::nargs !........ numero de argumentos efetivamente passados! ! integer::i !................................. Variavel auxiliar! ! ! ! call getarg2(namearg,arg,nargs) ! ! ! ! do i=1, nargs ! ! print *,namearg(i)," = ",trim(arg(i)) ! ! end do ! !-----------------------------------------------------------------------------! ! DEPENDEDIAS: getarg (sistema operacional) ! !-----------------------------------------------------------------------------! subroutine getarg2(argnames,args,nargs) !{ Variaveis da interface character(len=*),dimension(:),intent(out)::argnames character(len=*),dimension(:),intent(out)::args integer,intent(out)::nargs !} !{ Variaveis locais integer*2::argc character(len=1024)::indate integer::i,j !} i=ubound(argnames,1) argc = iargc() if (argc>i) argc=i argnames(1:argc)=" " args(1:argc)=" " i=0 j=0 k=0 DO while (i