Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/bilan_dyn.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/bilan_dyn.F (revision 1180) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3d/bilan_dyn.F (revision 1186) @@ -1,4 +1,4 @@ ! -! $Header$ +! $Id$ ! SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum, @@ -10,5 +10,7 @@ c vQ..A=Cp T + L * ... +#ifdef CPP_IOIPSL USE IOIPSL +#endif IMPLICIT NONE Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/diagedyn.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/diagedyn.F (revision 1180) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3d/diagedyn.F (revision 1186) @@ -1,4 +1,4 @@ ! -! $Header$ +! $Id$ ! @@ -315,5 +315,5 @@ C #else - write(lunout,*),'diagedyn: Needs Earth physics to function' + write(lunout,*)'diagedyn: Needs Earth physics to function' #endif ! #endif of #ifdef CPP_EARTH Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/dynredem.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/dynredem.F (revision 1180) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3d/dynredem.F (revision 1186) @@ -1,8 +1,10 @@ ! -! $Header$ +! $Id$ ! c SUBROUTINE dynredem0(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL USE IOIPSL +#endif USE infotrac IMPLICIT NONE @@ -55,9 +57,15 @@ c----------------------------------------------------------------------- - modname='dynredem' - + modname='dynredem0' + +#ifdef CPP_IOIPSL call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) - +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif DO l=1,length Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/getparam.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/getparam.F90 (revision 1180) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3d/getparam.F90 (revision 1186) @@ -1,7 +1,13 @@ ! -! $Header$ +! $Id$ ! MODULE getparam +#ifdef CPP_IOIPSL USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + INTERFACE getpar MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/guide_mod.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/guide_mod.F90 (revision 1180) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3d/guide_mod.F90 (revision 1186) @@ -1,4 +1,4 @@ ! -! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/guide.F,v 1.3.4.1 2006/11/06 15:51:16 fairhead Exp $ +! $Id$ ! MODULE guide_mod @@ -9,5 +9,4 @@ !======================================================================= - USE ioipsl USE getparam USE Write_Field Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/ioipsl_getincom.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/ioipsl_getincom.F90 (revision 1180) +++ (revision ) @@ -1,2609 +1,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Module and routines in this file are taken from IOIPSL -! files getincom.f90 -! Module names has been changed to avoid problems -! if compiling model with IOIPSL library -! Ehouarn - March 2009 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MODULE ioipsl_getincom -!--------------------------------------------------------------------- - USE ioipsl_stringop, & - & ONLY : findpos,nocomma,cmpblank,strlowercase,gensig,find_sig -!- - IMPLICIT NONE -!- - PRIVATE - PUBLIC :: getin, getin_dump -!- - INTERFACE getin - MODULE PROCEDURE getinrs, getinr1d, getinr2d, & - & getinis, getini1d, getini2d, & - & getincs, getinc1d, getinc2d, & - & getinls, getinl1d, getinl2d - END INTERFACE -!- - INTEGER,PARAMETER :: max_files=100 - CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist - INTEGER,SAVE :: nbfiles -!- - INTEGER,PARAMETER :: max_lines=4000 - INTEGER,SAVE :: nb_lines - CHARACTER(LEN=100),DIMENSION(max_lines),SAVE :: fichier - INTEGER,DIMENSION(max_lines),SAVE :: targetsiglist,fromfile,compline - CHARACTER(LEN=30),DIMENSION(max_lines),SAVE :: targetlist -!- -! The data base of parameters -!- - INTEGER,PARAMETER :: memslabs=200 - INTEGER,PARAMETER :: compress_lim = 20 -!- - INTEGER,SAVE :: nb_keys=0 - INTEGER,SAVE :: keymemsize=0 - INTEGER,SAVE,ALLOCATABLE :: keysig(:) - CHARACTER(LEN=30),SAVE,ALLOCATABLE :: keystr(:) -!- -! keystatus definition -! keystatus = 1 : Value comes from run.def -! keystatus = 2 : Default value is used -! keystatus = 3 : Some vector elements were taken from default -!- - INTEGER,SAVE,ALLOCATABLE :: keystatus(:) -!- -! keytype definition -! keytype = 1 : Interger -! keytype = 2 : Real -! keytype = 3 : Character -! keytype = 4 : Logical -!- - INTEGER,SAVE,ALLOCATABLE :: keytype(:) -!- -! Allow compression for keys (only for integer and real) -! keycompress < 0 : not compresses -! keycompress > 0 : number of repeat of the value -!- - INTEGER,SAVE,ALLOCATABLE :: keycompress(:) - INTEGER,SAVE,ALLOCATABLE :: keyfromfile(:) -!- - INTEGER,SAVE,ALLOCATABLE :: keymemstart(:) - INTEGER,SAVE,ALLOCATABLE :: keymemlen(:) -!- - INTEGER,SAVE,ALLOCATABLE :: intmem(:) - INTEGER,SAVE :: intmemsize=0, intmempos=0 - REAL,SAVE,ALLOCATABLE :: realmem(:) - INTEGER,SAVE :: realmemsize=0, realmempos=0 - CHARACTER(LEN=100),SAVE,ALLOCATABLE :: charmem(:) - INTEGER,SAVE :: charmemsize=0, charmempos=0 - LOGICAL,SAVE,ALLOCATABLE :: logicmem(:) - INTEGER,SAVE :: logicmemsize=0, logicmempos=0 -!- -CONTAINS -!- -!=== REAL INTERFACES -!- -SUBROUTINE getinrs (TARGET,ret_val) -!--------------------------------------------------------------------- -!- Get a real scalar. We first check if we find it -!- in the database and if not we get it from the run.def -!- -!- getinr1d and getinr2d are written on the same pattern -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - REAL :: ret_val -!- - REAL,DIMENSION(1) :: tmp_ret_val - INTEGER :: target_sig, pos, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - tmp_ret_val(1) = ret_val -!- - IF (pos < 0) THEN -!-- Get the information out of the file - CALL getfilr (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwr (TARGET,target_sig,status,fileorig,1,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrr (pos,1,TARGET,tmp_ret_val) - ENDIF - ret_val = tmp_ret_val(1) -!--------------------- -END SUBROUTINE getinrs -!- -!=== -!- -SUBROUTINE getinr1d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getinrs for details. It is the same thing but for a vector -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - REAL,DIMENSION(:) :: ret_val -!- - REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig, pos, size_of_in, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF - tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfilr (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwr & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF - ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) -!---------------------- -END SUBROUTINE getinr1d -!- -!=== -!- -SUBROUTINE getinr2d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getinrs for details. It is the same thing but for a matrix -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - REAL,DIMENSION(:,:) :: ret_val -!- - REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig - INTEGER :: jl, jj, ji -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - size_1 = SIZE(ret_val,1) - size_2 = SIZE(ret_val,2) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - tmp_ret_val(jl) = ret_val(ji,jj) - ENDDO - ENDDO -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfilr (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwr & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - ret_val(ji,jj) = tmp_ret_val(jl) - ENDDO - ENDDO -!---------------------- -END SUBROUTINE getinr2d -!- -!=== -!- -SUBROUTINE getfilr (TARGET,status,fileorig,ret_val) -!--------------------------------------------------------------------- -!- Subroutine that will extract from the file the values -!- attributed to the keyword target -!- -!- REALS -!- ----- -!- -!- target : in : CHARACTER(LEN=*) target for which we will -!- look in the file -!- status : out : INTEGER tells us from where we obtained the data -!- fileorig : out : The index of the file from which the key comes -!- ret_val : out : REAL(nb_to_ret) values read -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - INTEGER :: status, fileorig - REAL,DIMENSION(:) :: ret_val -!- - INTEGER :: nb_to_ret - INTEGER :: it, pos, len_str, epos, ppos, int_tmp, status_cnt - CHARACTER(LEN=3) :: cnt, tl, dl - CHARACTER(LEN=10) :: fmt - CHARACTER(LEN=30) :: full_target - CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp - INTEGER :: full_target_sig - REAL :: compvalue -!- - INTEGER,SAVE :: max_len = 0 - LOGICAL,SAVE,ALLOCATABLE :: found(:) - LOGICAL :: def_beha - LOGICAL :: compressed = .FALSE. -!--------------------------------------------------------------------- - nb_to_ret = SIZE(ret_val) - CALL getin_read -!- -! Get the variables and memory we need -!- - IF (max_len == 0) THEN - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - IF (max_len < nb_to_ret) THEN - DEALLOCATE(found) - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - found(:) = .FALSE. -!- -! See what we find in the files read -!- - DO it=1,nb_to_ret -!--- -!- -!-- First try the target as it is -!--- - full_target = TARGET(1:len_TRIM(target)) - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) -!--- -!-- Another try -!--- - IF (pos < 0) THEN - WRITE(cnt,'(I3.3)') it - full_target = TARGET(1:len_TRIM(target))//'__'//cnt - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) - ENDIF -!--- -!-- A priori we dont know from which file the target could come. -!-- Thus by default we attribute it to the first file : -!--- - fileorig = 1 -!-- - IF (pos > 0) THEN -!---- - found(it) = .TRUE. - fileorig = fromfile(pos) -!----- -!---- DECODE -!----- - str_READ = TRIM(ADJUSTL(fichier(pos))) - str_READ_lower = str_READ - CALL strlowercase (str_READ_lower) -!---- - IF ( ( (INDEX(str_READ_lower,'def') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & - & .OR.( (INDEX(str_READ_lower,'default') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN - def_beha = .TRUE. - ELSE - def_beha = .FALSE. - len_str = LEN_TRIM(str_READ) - epos = INDEX(str_READ,'e') - ppos = INDEX(str_READ,'.') -!------ - IF (epos > 0) THEN - WRITE(tl,'(I3.3)') len_str - WRITE(dl,'(I3.3)') epos-ppos-1 - fmt='(e'//tl//'.'//dl//')' - READ(str_READ,fmt) ret_val(it) - ELSE IF (ppos > 0) THEN - WRITE(tl,'(I3.3)') len_str - WRITE(dl,'(I3.3)') len_str-ppos - fmt='(f'//tl//'.'//dl//')' - READ(str_READ,fmt) ret_val(it) - ELSE - WRITE(tl,'(I3.3)') len_str - fmt = '(I'//tl//')' - READ(str_READ,fmt) int_tmp - ret_val(it) = REAL(int_tmp) - ENDIF - ENDIF -!---- - targetsiglist(pos) = -1 -!----- -!---- Is this the value of a compressed field ? -!----- - IF (compline(pos) > 0) THEN - IF (compline(pos) == nb_to_ret) THEN - compressed = .TRUE. - compvalue = ret_val(it) - ELSE - WRITE(*,*) 'WARNING from getfilr' - WRITE(*,*) 'For key ',TRIM(TARGET), & - & ' we have a compressed field but which does not have the right size.' - WRITE(*,*) 'We will try to fix that ' - compressed = .TRUE. - compvalue = ret_val(it) - ENDIF - ENDIF - ELSE - found(it) = .FALSE. - ENDIF - ENDDO -!-- -! If this is a compressed field then we will uncompress it -!-- - IF (compressed) THEN - DO it=1,nb_to_ret - IF (.NOT. found(it)) THEN - ret_val(it) = compvalue - found(it) = .TRUE. - ENDIF - ENDDO - ENDIF -!- -! Now we get the status for what we found -!- - IF (def_beha) THEN - status = 2 - WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) - ELSE - status_cnt = 0 - DO it=1,nb_to_ret - IF (.NOT. found(it)) THEN - status_cnt = status_cnt+1 - IF (nb_to_ret > 1) THEN - WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it - ELSE - str_tmp = TRIM(TARGET) - ENDIF - WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) - ENDIF - ENDDO -!--- - IF (status_cnt == 0) THEN - status = 1 - ELSE IF (status_cnt == nb_to_ret) THEN - status = 2 - ELSE - status = 3 - ENDIF - ENDIF -!--------------------- -END SUBROUTINE getfilr -!- -!=== INTEGER INTERFACES -!- -SUBROUTINE getinis (TARGET,ret_val) -!--------------------------------------------------------------------- -!- Get a interer scalar. We first check if we find it -!- in the database and if not we get it from the run.def -!- -!- getini1d and getini2d are written on the same pattern -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - INTEGER :: ret_val -!- - INTEGER,DIMENSION(1) :: tmp_ret_val - INTEGER :: target_sig, pos, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - tmp_ret_val(1) = ret_val -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfili (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwi (TARGET,target_sig,status,fileorig,1,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbri (pos,1,TARGET,tmp_ret_val) - ENDIF - ret_val = tmp_ret_val(1) -!--------------------- -END SUBROUTINE getinis -!- -!=== -!- -SUBROUTINE getini1d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getinis for details. It is the same thing but for a vector -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - INTEGER,DIMENSION(:) :: ret_val -!- - INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig, pos, size_of_in, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF - tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfili (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwi & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF - ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) -!---------------------- -END SUBROUTINE getini1d -!- -!=== -!- -SUBROUTINE getini2d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getinis for details. It is the same thing but for a matrix -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - INTEGER,DIMENSION(:,:) :: ret_val -!- - INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig - INTEGER :: jl, jj, ji -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - size_1 = SIZE(ret_val,1) - size_2 = SIZE(ret_val,2) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - tmp_ret_val(jl) = ret_val(ji,jj) - ENDDO - ENDDO -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfili (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwi & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - ret_val(ji,jj) = tmp_ret_val(jl) - ENDDO - ENDDO -!---------------------- -END SUBROUTINE getini2d -!- -!=== -!- -SUBROUTINE getfili (TARGET,status,fileorig,ret_val) -!--------------------------------------------------------------------- -!- Subroutine that will extract from the file the values -!- attributed to the keyword target -!- -!- INTEGER -!- ------- -!- -!- target : in : CHARACTER(LEN=*) target for which we will -!- look in the file -!- status : out : INTEGER tells us from where we obtained the data -!- fileorig : out : The index of the file from which the key comes -!- ret_val : out : INTEGER(nb_to_ret) values read -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - INTEGER :: status, fileorig - INTEGER :: ret_val(:) -!- - INTEGER :: nb_to_ret - INTEGER :: it, pos, len_str, status_cnt - CHARACTER(LEN=3) :: cnt, chlen - CHARACTER(LEN=10) :: fmt - CHARACTER(LEN=30) :: full_target - CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp - INTEGER :: full_target_sig - INTEGER :: compvalue -!- - INTEGER,SAVE :: max_len = 0 - LOGICAL,SAVE,ALLOCATABLE :: found(:) - LOGICAL :: def_beha - LOGICAL :: compressed = .FALSE. -!--------------------------------------------------------------------- - nb_to_ret = SIZE(ret_val) - CALL getin_read -!- -! Get the variables and memory we need -!- - IF (max_len == 0) THEN - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - IF (max_len < nb_to_ret) THEN - DEALLOCATE(found) - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - found(:) = .FALSE. -!- -! See what we find in the files read -!- - DO it=1,nb_to_ret -!--- -!-- First try the target as it is -!--- - full_target = TARGET(1:len_TRIM(target)) - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) -!--- -!-- Another try -!--- - IF (pos < 0) THEN - WRITE(cnt,'(I3.3)') it - full_target = TARGET(1:len_TRIM(target))//'__'//cnt - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) - ENDIF -!--- -!-- A priori we dont know from which file the target could come. -!-- Thus by default we attribute it to the first file : -!--- - fileorig = 1 -!- - IF (pos > 0) THEN -!----- - found(it) = .TRUE. - fileorig = fromfile(pos) -!----- -!---- DECODE -!---- - str_READ = TRIM(ADJUSTL(fichier(pos))) - str_READ_lower = str_READ - CALL strlowercase (str_READ_lower) -!----- - IF ( ( (INDEX(str_READ_lower,'def') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & - & .OR.( (INDEX(str_READ_lower,'default') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN - def_beha = .TRUE. - ELSE - def_beha = .FALSE. - len_str = LEN_TRIM(str_READ) - WRITE(chlen,'(I3.3)') len_str - fmt = '(I'//chlen//')' - READ(str_READ,fmt) ret_val(it) - ENDIF -!----- - targetsiglist(pos) = -1 -!----- -!---- Is this the value of a compressed field ? -!----- - IF (compline(pos) > 0) THEN - IF (compline(pos) == nb_to_ret) THEN - compressed = .TRUE. - compvalue = ret_val(it) - ELSE - WRITE(*,*) 'WARNING from getfilr' - WRITE(*,*) 'For key ',TRIM(TARGET), & - & ' we have a compressed field but which does not have the right size.' - WRITE(*,*) 'We will try to fix that ' - compressed = .TRUE. - compvalue = ret_val(it) - ENDIF - ENDIF - ELSE - found(it) = .FALSE. - ENDIF - ENDDO -!- -! If this is a compressed field then we will uncompress it -!- - IF (compressed) THEN - DO it=1,nb_to_ret - IF (.NOT. found(it)) THEN - ret_val(it) = compvalue - found(it) = .TRUE. - ENDIF - ENDDO - ENDIF -!- -! Now we get the status for what we found -!- - IF (def_beha) THEN - status = 2 - WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) - ELSE - status_cnt = 0 - DO it=1,nb_to_ret - IF (.NOT. found(it)) THEN - status_cnt = status_cnt+1 - IF (nb_to_ret > 1) THEN - WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it - ELSE - str_tmp = TRIM(TARGET) - ENDIF - WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) - ENDIF - ENDDO -!--- - IF (status_cnt == 0) THEN - status = 1 - ELSE IF (status_cnt == nb_to_ret) THEN - status = 2 - ELSE - status = 3 - ENDIF - ENDIF -!--------------------- -END SUBROUTINE getfili -!- -!=== CHARACTER INTERFACES -!- -SUBROUTINE getincs (TARGET,ret_val) -!--------------------------------------------------------------------- -!- Get a CHARACTER scalar. We first check if we find it -!- in the database and if not we get it from the run.def -!- -!- getinc1d and getinc2d are written on the same pattern -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - CHARACTER(LEN=*) :: ret_val -!- - CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val - INTEGER :: target_sig, pos, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - tmp_ret_val(1) = ret_val -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfilc (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwc (TARGET,target_sig,status,fileorig,1,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrc (pos,1,TARGET,tmp_ret_val) - ENDIF - ret_val = tmp_ret_val(1) -!--------------------- -END SUBROUTINE getincs -!- -!=== -!- -SUBROUTINE getinc1d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getincs for details. It is the same thing but for a vector -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - CHARACTER(LEN=*),DIMENSION(:) :: ret_val -!- - CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig, pos, size_of_in, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF - tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfilc (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwc & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF - ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) -!---------------------- -END SUBROUTINE getinc1d -!- -!=== -!- -SUBROUTINE getinc2d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getincs for details. It is the same thing but for a matrix -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val -!- - CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig - INTEGER :: jl,jj,ji -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - size_1 = SIZE(ret_val,1) - size_2 = SIZE(ret_val,2) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - tmp_ret_val(jl) = ret_val(ji,jj) - ENDDO - ENDDO -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfilc (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwc & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - ret_val(ji,jj) = tmp_ret_val(jl) - ENDDO - ENDDO -!---------------------- -END SUBROUTINE getinc2d -!- -!=== -!- -SUBROUTINE getfilc (TARGET,status,fileorig,ret_val) -!--------------------------------------------------------------------- -!- Subroutine that will extract from the file the values -!- attributed to the keyword target -!- -!- CHARACTER -!- --------- -!- -!- target : in : CHARACTER(LEN=*) target for which we will -!- look in the file -!- status : out : INTEGER tells us from where we obtained the data -!- fileorig : out : The index of the file from which the key comes -!- ret_val : out : CHARACTER(nb_to_ret) values read -!--------------------------------------------------------------------- - IMPLICIT NONE -!- -!- - CHARACTER(LEN=*) :: TARGET - INTEGER :: status, fileorig - CHARACTER(LEN=*),DIMENSION(:) :: ret_val -!- - INTEGER :: nb_to_ret - INTEGER :: it, pos, len_str, status_cnt - CHARACTER(LEN=3) :: cnt - CHARACTER(LEN=30) :: full_target - CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp - INTEGER :: full_target_sig -!- - INTEGER,SAVE :: max_len = 0 - LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found - LOGICAL :: def_beha -!--------------------------------------------------------------------- - nb_to_ret = SIZE(ret_val) - CALL getin_read -!- -! Get the variables and memory we need -!- - IF (max_len == 0) THEN - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - IF (max_len < nb_to_ret) THEN - DEALLOCATE(found) - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - found(:) = .FALSE. -!- -! See what we find in the files read -!- - DO it=1,nb_to_ret -!--- -!-- First try the target as it is - full_target = TARGET(1:len_TRIM(target)) - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) -!--- -!-- Another try -!--- - IF (pos < 0) THEN - WRITE(cnt,'(I3.3)') it - full_target = TARGET(1:len_TRIM(target))//'__'//cnt - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) - ENDIF -!--- -!-- A priori we dont know from which file the target could come. -!-- Thus by default we attribute it to the first file : -!--- - fileorig = 1 -!--- - IF (pos > 0) THEN -!----- - found(it) = .TRUE. - fileorig = fromfile(pos) -!----- -!---- DECODE -!----- - str_READ = TRIM(ADJUSTL(fichier(pos))) - str_READ_lower = str_READ - CALL strlowercase (str_READ_lower) -!----- - IF ( ( (INDEX(str_READ_lower,'def') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & - & .OR.( (INDEX(str_READ_lower,'default') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN - def_beha = .TRUE. - ELSE - def_beha = .FALSE. - len_str = LEN_TRIM(str_READ) - ret_val(it) = str_READ(1:len_str) - ENDIF -!----- - targetsiglist(pos) = -1 -!----- - ELSE - found(it) = .FALSE. - ENDIF - ENDDO -!- -! Now we get the status for what we found -!- - IF (def_beha) THEN - status = 2 - WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) - ELSE - status_cnt = 0 - DO it=1,nb_to_ret - IF (.NOT. found(it)) THEN - status_cnt = status_cnt+1 - IF (nb_to_ret > 1) THEN - WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it - ELSE - str_tmp = TARGET(1:len_TRIM(target)) - ENDIF - WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) - ENDIF - ENDDO -!- - IF (status_cnt == 0) THEN - status = 1 - ELSE IF (status_cnt == nb_to_ret) THEN - status = 2 - ELSE - status = 3 - ENDIF - ENDIF -!--------------------- -END SUBROUTINE getfilc -!- -!=== LOGICAL INTERFACES -!- -SUBROUTINE getinls (TARGET,ret_val) -!--------------------------------------------------------------------- -!- Get a logical scalar. We first check if we find it -!- in the database and if not we get it from the run.def -!- -!- getinl1d and getinl2d are written on the same pattern -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - LOGICAL :: ret_val -!- - LOGICAL,DIMENSION(1) :: tmp_ret_val - INTEGER :: target_sig, pos, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - tmp_ret_val(1) = ret_val -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfill (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwl (TARGET,target_sig,status,fileorig,1,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrl (pos,1,TARGET,tmp_ret_val) - ENDIF - ret_val = tmp_ret_val(1) -!--------------------- -END SUBROUTINE getinls -!- -!=== -!- -SUBROUTINE getinl1d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getinls for details. It is the same thing but for a vector -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - LOGICAL,DIMENSION(:) :: ret_val -!- - LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig, pos, size_of_in, status=0, fileorig -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF - tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfill (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwl & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF - ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) -!---------------------- -END SUBROUTINE getinl1d -!- -!=== -!- -SUBROUTINE getinl2d (TARGET,ret_val) -!--------------------------------------------------------------------- -!- See getinls for details. It is the same thing but for a matrix -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - LOGICAL,DIMENSION(:,:) :: ret_val -!- - LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val - INTEGER,SAVE :: tmp_ret_size = 0 - INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig - INTEGER :: jl,jj,ji -!--------------------------------------------------------------------- -!- -! Compute the signature of the target -!- - CALL gensig (TARGET,target_sig) -!- -! Do we have this target in our database ? -!- - CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) -!- - size_of_in = SIZE(ret_val) - size_1 = SIZE(ret_val,1) - size_2 = SIZE(ret_val,2) - IF (.NOT.ALLOCATED(tmp_ret_val)) THEN - ALLOCATE (tmp_ret_val(size_of_in)) - ELSE IF (size_of_in > tmp_ret_size) THEN - DEALLOCATE (tmp_ret_val) - ALLOCATE (tmp_ret_val(size_of_in)) - tmp_ret_size = size_of_in - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - tmp_ret_val(jl) = ret_val(ji,jj) - ENDDO - ENDDO -!- - IF (pos < 0) THEN -!-- Ge the information out of the file - CALL getfill (TARGET,status,fileorig,tmp_ret_val) -!-- Put the data into the database - CALL getdbwl & - & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) - ELSE -!-- Get the value out of the database - CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val) - ENDIF -!- - jl=0 - DO jj=1,size_2 - DO ji=1,size_1 - jl=jl+1 - ret_val(ji,jj) = tmp_ret_val(jl) - ENDDO - ENDDO -!---------------------- -END SUBROUTINE getinl2d -!- -!=== -!- -SUBROUTINE getfill (TARGET,status,fileorig,ret_val) -!--------------------------------------------------------------------- -!- Subroutine that will extract from the file the values -!- attributed to the keyword target -!- -!- LOGICAL -!- ------- -!- -!- target : in : CHARACTER(LEN=*) target for which we will -!- look in the file -!- status : out : INTEGER tells us from where we obtained the data -!- fileorig : out : The index of the file from which the key comes -!- ret_val : out : LOGICAL(nb_to_ret) values read -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: TARGET - INTEGER :: status, fileorig - LOGICAL,DIMENSION(:) :: ret_val -!- - INTEGER :: nb_to_ret - INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, status_cnt - CHARACTER(LEN=3) :: cnt - CHARACTER(LEN=30) :: full_target - CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp - INTEGER :: full_target_sig -!- - INTEGER,SAVE :: max_len = 0 - LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found - LOGICAL :: def_beha -!--------------------------------------------------------------------- - nb_to_ret = SIZE(ret_val) - CALL getin_read -!- -! Get the variables and memory we need -!- - IF (max_len == 0) THEN - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - IF (max_len < nb_to_ret) THEN - DEALLOCATE(found) - ALLOCATE(found(nb_to_ret)) - max_len = nb_to_ret - ENDIF - found(:) = .FALSE. -!- -! See what we find in the files read -!- - DO it=1,nb_to_ret -!--- -!-- First try the target as it is -!--- - full_target = TARGET(1:len_TRIM(target)) - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) -!--- -!-- Another try -!--- - IF (pos < 0) THEN - WRITE(cnt,'(I3.3)') it - full_target = TARGET(1:len_TRIM(target))//'__'//cnt - CALL gensig (full_target,full_target_sig) - CALL find_sig (nb_lines,targetlist,full_target, & - & targetsiglist,full_target_sig,pos) - ENDIF -!--- -!-- A priori we dont know from which file the target could come. -!-- Thus by default we attribute it to the first file : -!--- - fileorig = 1 -!--- - IF (pos > 0) THEN -!----- - found(it) = .TRUE. - fileorig = fromfile(pos) -!----- -!---- DECODE -!----- - str_READ = TRIM(ADJUSTL(fichier(pos))) - str_READ_lower = str_READ - CALL strlowercase (str_READ_lower) -!----- - IF ( ( (INDEX(str_READ_lower,'def') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & - & .OR.( (INDEX(str_READ_lower,'default') == 1) & - & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN - def_beha = .TRUE. - ELSE - def_beha = .FALSE. - len_str = LEN_TRIM(str_READ) - ipos_tr = -1 - ipos_fl = -1 -!------- - ipos_tr = MAX(INDEX(str_READ,'tru'),INDEX(str_READ,'TRU'), & - & INDEX(str_READ,'y'),INDEX(str_READ,'Y')) - ipos_fl = MAX(INDEX(str_READ,'fal'),INDEX(str_READ,'FAL'), & - & INDEX(str_READ,'n'),INDEX(str_READ,'N')) -!------- - IF (ipos_tr > 0) THEN - ret_val(it) = .TRUE. - ELSE IF (ipos_fl > 0) THEN - ret_val(it) = .FALSE. - ELSE - WRITE(*,*) "ERROR : getfill : TARGET ", & - & TRIM(TARGET)," is not of logical value" - STOP 'getinl' - ENDIF - ENDIF -!----- - targetsiglist(pos) = -1 -!----- - ELSE -!- - found(it) = .FALSE. -!- - ENDIF -!- - ENDDO -!- -! Now we get the status for what we found -!- - IF (def_beha) THEN - status = 2 - WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) - ELSE - status_cnt = 0 - DO it=1,nb_to_ret - IF (.NOT. found(it)) THEN - status_cnt = status_cnt+1 - IF (nb_to_ret > 1) THEN - WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it - ELSE - str_tmp = TRIM(TARGET) - ENDIF - WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) - ENDIF - ENDDO -!--- - IF (status_cnt == 0) THEN - status = 1 - ELSE IF (status_cnt == nb_to_ret) THEN - status = 2 - ELSE - status = 3 - ENDIF - ENDIF -!--------------------- -END SUBROUTINE getfill -!- -!=== -!- -SUBROUTINE getin_read -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER,SAVE :: allread=0 - INTEGER,SAVE :: current,i -!--------------------------------------------------------------------- - IF (allread == 0) THEN -!-- Allocate a first set of memory. - CALL getin_allockeys - CALL getin_allocmem (1,0) - CALL getin_allocmem (2,0) - CALL getin_allocmem (3,0) - CALL getin_allocmem (4,0) -!-- Start with reading the files - nbfiles = 1 - filelist(1) = 'run.def' - current = 1 - nb_lines = 0 -!-- - DO WHILE (current <= nbfiles) - CALL getin_readdef (current) - current = current+1 - ENDDO - allread = 1 - CALL getin_checkcohe () - ENDIF -!------------------------ -END SUBROUTINE getin_read -!- -!=== -!- - SUBROUTINE getin_readdef(current) -!--------------------------------------------------------------------- -!- This subroutine will read the files and only keep the -!- the relevant information. The information is kept as it -!- found in the file. The data will be analysed later. -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: current -!- - CHARACTER(LEN=100) :: READ_str, NEW_str, new_key, last_key, key_str - CHARACTER(LEN=3) :: cnt - INTEGER :: nb_lastkey -!- - INTEGER :: eof, ptn, len_str, i, it, iund - LOGICAL :: check = .FALSE. -!--------------------------------------------------------------------- - eof = 0 - ptn = 1 - nb_lastkey = 0 -!- - IF (check) THEN - WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) - ENDIF -!- - OPEN (22,file=filelist(current),ERR=9997,STATUS="OLD") -!- - DO WHILE (eof /= 1) -!--- - CALL getin_skipafew (22,READ_str,eof,nb_lastkey) - len_str = LEN_TRIM(READ_str) - ptn = INDEX(READ_str,'=') -!--- - IF (ptn > 0) THEN -!---- Get the target - key_str = TRIM(ADJUSTL(READ_str(1:ptn-1))) -!---- Make sure that if a vector keyword has the right length - iund = INDEX(key_str,'__') - IF (iund > 0) THEN - SELECTCASE( len_trim(key_str)-iund ) - CASE(2) - READ(key_str(iund+2:len_trim(key_str)),'(I1)') it - CASE(3) - READ(key_str(iund+2:len_trim(key_str)),'(I2)') it - CASE(4) - READ(key_str(iund+2:len_trim(key_str)),'(I3)') it - CASE DEFAULT - it = -1 - END SELECT - IF (it > 0) THEN - WRITE(cnt,'(I3.3)') it - key_str = key_str(1:iund+1)//cnt - ELSE - WRITE(*,*) & - & 'getin_readdef : A very strange key has just been found' - WRITE(*,*) 'getin_readdef : ',key_str(1:len_TRIM(key_str)) - STOP 'getin_readdef' - ENDIF - ENDIF -!---- Prepare the content - NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str))) - CALL nocomma (NEW_str) - CALL cmpblank (NEW_str) - NEW_str = TRIM(ADJUSTL(NEW_str)) - IF (check) THEN - WRITE(*,*) & - & '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) - ENDIF -!---- Decypher the content of NEW_str -!- -!---- This has to be a new key word, thus : - nb_lastkey = 0 -!---- - CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) -!---- - ELSE IF (len_str > 0) THEN -!---- Prepare the key if we have an old one to which -!---- we will add the line just read - IF (nb_lastkey > 0) THEN - iund = INDEX(last_key,'__') - IF (iund > 0) THEN -!-------- We only continue a keyword, thus it is easy - key_str = last_key(1:iund-1) - ELSE - IF (nb_lastkey /= 1) THEN - WRITE(*,*) & - & 'getin_readdef : An error has occured. We can not have a scalar' - WRITE(*,*) 'getin_readdef : keywod and a vector content' - STOP 'getin_readdef' - ENDIF -!-------- The last keyword needs to be transformed into a vector. - targetlist(nb_lines) = & - & last_key(1:MIN(len_trim(last_key),30))//'__001' - CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) - key_str = last_key(1:len_TRIM(last_key)) - ENDIF - ENDIF -!---- Prepare the content - NEW_str = TRIM(ADJUSTL(READ_str(1:len_str))) - CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) - ELSE -!---- If we have an empty line the the keyword finishes - nb_lastkey = 0 - IF (check) THEN - WRITE(*,*) 'getin_readdef : Have found an emtpy line ' - ENDIF - ENDIF - ENDDO -!- - CLOSE(22) -!- - IF (check) THEN - OPEN (22,file='run.def.test') - DO i=1,nb_lines - WRITE(22,*) targetlist(i)," : ",fichier(i) - ENDDO - CLOSE(22) - ENDIF -!- - RETURN -!- -9997 WRITE(*,*) "getin_readdef : Could not open file ", & - & TRIM(filelist(current)) -!--------------------------- -END SUBROUTINE getin_readdef -!- -!=== -!- -SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey) -!--------------------------------------------------------------------- -!- This subroutine is going to decypher the line. -!- It essentialy checks how many items are included and -!- it they can be attached to a key. -!--------------------------------------------------------------------- - IMPLICIT NONE -!- -! ARGUMENTS -!- - INTEGER :: current, nb_lastkey - CHARACTER(LEN=*) :: key_str, NEW_str, last_key -!- -! LOCAL -!- - INTEGER :: len_str, blk, nbve, starpos - CHARACTER(LEN=100) :: tmp_str, new_key, mult - CHARACTER(LEN=3) :: cnt, chlen - CHARACTER(LEN=10) :: fmt -!--------------------------------------------------------------------- - len_str = LEN_TRIM(NEW_str) - blk = INDEX(NEW_str(1:len_str),' ') - tmp_str = NEW_str(1:len_str) -!- -! If the key is a new file then we take it up. Else -! we save the line and go on. -!- - IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN - DO WHILE (blk > 0) - IF (nbfiles+1 > max_files) THEN - WRITE(*,*) 'FATAL ERROR : Too many files to include' - STOP 'getin_readdef' - ENDIF -!----- - nbfiles = nbfiles+1 - filelist(nbfiles) = tmp_str(1:blk) -!----- - tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) - blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ') - ENDDO -!--- - IF (nbfiles+1 > max_files) THEN - WRITE(*,*) 'FATAL ERROR : Too many files to include' - STOP 'getin_readdef' - ENDIF -!--- - nbfiles = nbfiles+1 - filelist(nbfiles) = TRIM(ADJUSTL(tmp_str)) -!--- - last_key = 'INCLUDEDEF' - nb_lastkey = 1 - ELSE -!- -!-- We are working on a new line of input -!- - nb_lines = nb_lines+1 - IF (nb_lines > max_lines) THEN - WRITE(*,*) & - & 'Too many line in the run.def files. You need to increase' - WRITE(*,*) 'the parameter max_lines in the module getincom.' - STOP 'getin_decrypt' - ENDIF -!- -!-- First we solve the issue of conpressed information. Once -!-- this is done all line can be handled in the same way. -!- - starpos = INDEX(NEW_str(1:len_str),'*') - IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') & - & .AND.(tmp_str(1:1) /= "'") ) THEN -!----- - IF (INDEX(key_str(1:len_TRIM(key_str)),'__') > 0) THEN - WRITE(*,*) 'ERROR : getin_decrypt' - WRITE(*,*) & -& 'We can not have a compressed field of values for in a' - WRITE(*,*) & -& 'vector notation. If a target is of the type TARGET__1' - WRITE(*,*) 'then only a scalar value is allowed' - WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str)) - STOP 'getin_decrypt' - ENDIF -!- -!---- Read the multiplied -!- - mult = TRIM(ADJUSTL(NEW_str(1:starpos-1))) -!---- Construct the new string and its parameters - NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str))) - len_str = LEN_TRIM(NEW_str) - blk = INDEX(NEW_str(1:len_str),' ') - IF (blk > 1) THEN - WRITE(*,*) & - & 'This is a strange behavior of getin_decrypt you could report' - ENDIF - WRITE(chlen,'(I3.3)') LEN_TRIM(mult) - fmt = '(I'//chlen//')' - READ(mult,fmt) compline(nb_lines) -!--- - ELSE - compline(nb_lines) = -1 - ENDIF -!- -!-- If there is no space wthin the line then the target is a scalar -!-- or the element of a properly written vector. -!-- (ie of the type TARGET__1) -!- - IF ( (blk <= 1) & - & .OR.(tmp_str(1:1) == '"') & - & .OR.(tmp_str(1:1) == "'") ) THEN -!- - IF (nb_lastkey == 0) THEN -!------ Save info of current keyword as a scalar -!------ if it is not a continuation - targetlist(nb_lines) = key_str(1:MIN(len_trim(key_str),30)) - last_key = key_str(1:MIN(len_trim(key_str),30)) - nb_lastkey = 1 - ELSE -!------ We are continuing a vector so the keyword needs -!------ to get the underscores - WRITE(cnt,'(I3.3)') nb_lastkey+1 - targetlist(nb_lines) = & - & key_str(1:MIN(len_trim(key_str),25))//'__'//cnt - last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt - nb_lastkey = nb_lastkey+1 - ENDIF -!----- - CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) - fichier(nb_lines) = NEW_str(1:len_str) - fromfile(nb_lines) = current - ELSE -!- -!---- If there are blanks whithin the line then we are dealing -!---- with a vector and we need to split it in many entries -!---- with the TRAGET__1 notation. -!---- -!---- Test if the targer is not already a vector target ! -!- - IF (INDEX(TRIM(key_str),'__') > 0) THEN - WRITE(*,*) 'ERROR : getin_decrypt' - WRITE(*,*) 'We have found a mixed vector notation' - WRITE(*,*) 'If a target is of the type TARGET__1' - WRITE(*,*) 'then only a scalar value is allowed' - WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str)) - STOP 'getin_decrypt' - ENDIF -!- - nbve = nb_lastkey - nbve = nbve+1 - WRITE(cnt,'(I3.3)') nbve -!- - DO WHILE (blk > 0) -!- -!------ Save the content of target__nbve -!- - fichier(nb_lines) = tmp_str(1:blk) - new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt - targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30)) - CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) - fromfile(nb_lines) = current -!- - tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) - blk = INDEX(TRIM(tmp_str),' ') -!- - nb_lines = nb_lines+1 - IF (nb_lines > max_lines) THEN - WRITE(*,*) & - & 'Too many line in the run.def files. You need to increase' - WRITE(*,*) 'the parameter max_lines in the module getincom.' - STOP 'getin_decrypt' - ENDIF - nbve = nbve+1 - WRITE(cnt,'(I3.3)') nbve -!- - ENDDO -!- -!---- Save the content of the last target -!- - fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) - new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt - targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30)) - CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) - fromfile(nb_lines) = current -!- - last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt - nb_lastkey = nbve -!- - ENDIF -!- - ENDIF -!--------------------------- -END SUBROUTINE getin_decrypt -!- -!=== -!- -SUBROUTINE getin_checkcohe () -!--------------------------------------------------------------------- -!- This subroutine checks for redundancies. -!--------------------------------------------------------------------- - IMPLICIT NONE -!- -! Arguments -!- -!- -! LOCAL -!- - INTEGER :: line,i,sig - INTEGER :: found - CHARACTER(LEN=30) :: str -!--------------------------------------------------------------------- - DO line=1,nb_lines-1 -!- - CALL find_sig & - & (nb_lines-line,targetlist(line+1:nb_lines),targetlist(line), & - & targetsiglist(line+1:nb_lines),targetsiglist(line),found) -!--- -!-- IF we have found it we have a problem to solve. -!--- - IF (found > 0) THEN - WRITE(*,*) 'COUNT : ', & - & COUNT(ABS(targetsiglist(line+1:nb_lines)-targetsiglist(line)) < 1) -!----- - WRITE(*,*) & - & 'getin_checkcohe : Found a problem on key ',targetlist(line) - WRITE(*,*) & - & 'getin_checkcohe : The following values were encoutered :' - WRITE(*,*) & - & ' ',TRIM(targetlist(line)), & - & targetsiglist(line),' == ',fichier(line) - WRITE(*,*) & - & ' ',TRIM(targetlist(line+found)), & - & targetsiglist(line+found),' == ',fichier(line+found) - WRITE(*,*) & - & 'getin_checkcohe : We will keep only the last value' -!----- - targetsiglist(line) = 1 - ENDIF - ENDDO -!- -END SUBROUTINE getin_checkcohe -!- -!=== -!- -SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey) -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: unit, eof, nb_lastkey - CHARACTER(LEN=100) :: dummy - CHARACTER(LEN=100) :: out_string - CHARACTER(LEN=1) :: first -!--------------------------------------------------------------------- - first="#" - eof = 0 - out_string = " " -!- - DO WHILE (first == "#") - READ (unit,'(a100)',ERR=9998,END=7778) dummy - dummy = TRIM(ADJUSTL(dummy)) - first=dummy(1:1) - IF (first == "#") THEN - nb_lastkey = 0 - ENDIF - ENDDO - out_string=dummy -!- - RETURN -!- -9998 WRITE(*,*) " GETIN_SKIPAFEW : Error while reading file " - STOP 'getin_skipafew' -!- -7778 eof = 1 -!---------------------------- -END SUBROUTINE getin_skipafew -!- -!=== INTEGER database INTERFACE -!- -SUBROUTINE getdbwi & - & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) -!--------------------------------------------------------------------- -!- Write the INTEGER data into the data base -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: target - INTEGER :: target_sig, status, fileorig, size_of_in - INTEGER,DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- -!- -! First check if we have sufficiant space for the new key -!- - IF (nb_keys+1 > keymemsize) THEN - CALL getin_allockeys () - ENDIF -!- -! Fill out the items of the data base -!- - nb_keys = nb_keys+1 - keysig(nb_keys) = target_sig - keystr(nb_keys) = target(1:MIN(len_trim(target),30)) - keystatus(nb_keys) = status - keytype(nb_keys) = 1 - keyfromfile(nb_keys) = fileorig -!- -! Can we compress the data base entry ? -!- - IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) & - & .AND.(size_of_in > compress_lim)) THEN - keymemstart(nb_keys) = intmempos+1 - keycompress(nb_keys) = size_of_in - keymemlen(nb_keys) = 1 - ELSE - keymemstart(nb_keys) = intmempos+1 - keycompress(nb_keys) = -1 - keymemlen(nb_keys) = size_of_in - ENDIF -!- -! Before writing the actual size lets see if we have the space -!- - IF (keymemstart(nb_keys)+keymemlen(nb_keys) > intmemsize) THEN - CALL getin_allocmem (1,keymemlen(nb_keys)) - ENDIF -!- - intmem(keymemstart(nb_keys): & - & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & - & tmp_ret_val(1:keymemlen(nb_keys)) - intmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 -!--------------------- -END SUBROUTINE getdbwi -!- -!=== -!- -SUBROUTINE getdbri (pos,size_of_in,target,tmp_ret_val) -!--------------------------------------------------------------------- -!- Read the required variables in the database for INTEGERS -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: pos, size_of_in - CHARACTER(LEN=*) :: target - INTEGER,DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- - IF (keytype(pos) /= 1) THEN - WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target - STOP 'getdbri' - ENDIF -!- - IF (keycompress(pos) > 0) THEN - IF ( keycompress(pos) /= size_of_in .OR. keymemlen(pos) /= 1 ) THEN - WRITE(*,*) & - & 'FATAL ERROR : Wrong compression length for keyword ',target - STOP 'getdbri' - ELSE - tmp_ret_val(1:size_of_in) = intmem(keymemstart(pos)) - ENDIF - ELSE - IF (keymemlen(pos) /= size_of_in) THEN - WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target - STOP 'getdbri' - ELSE - tmp_ret_val(1:size_of_in) = & - & intmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) - ENDIF - ENDIF -!--------------------- -END SUBROUTINE getdbri -!- -!=== REAL database INTERFACE -!- -SUBROUTINE getdbwr & - & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) -!--------------------------------------------------------------------- -!- Write the REAL data into the data base -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: target - INTEGER :: target_sig, status, fileorig, size_of_in - REAL,DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- -!- -! First check if we have sufficiant space for the new key -!- - IF (nb_keys+1 > keymemsize) THEN - CALL getin_allockeys () - ENDIF -!- -! Fill out the items of the data base -!- - nb_keys = nb_keys+1 - keysig(nb_keys) = target_sig - keystr(nb_keys) = target(1:MIN(len_trim(target),30)) - keystatus(nb_keys) = status - keytype(nb_keys) = 2 - keyfromfile(nb_keys) = fileorig -!- -! Can we compress the data base entry ? -!- - IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) & -& .AND.(size_of_in > compress_lim)) THEN - keymemstart(nb_keys) = realmempos+1 - keycompress(nb_keys) = size_of_in - keymemlen(nb_keys) = 1 - ELSE - keymemstart(nb_keys) = realmempos+1 - keycompress(nb_keys) = -1 - keymemlen(nb_keys) = size_of_in - ENDIF -!- -! Before writing the actual size lets see if we have the space -!- - IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN - CALL getin_allocmem (2,keymemlen(nb_keys)) - ENDIF -!- - realmem(keymemstart(nb_keys): & - & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & - & tmp_ret_val(1:keymemlen(nb_keys)) - realmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 -!--------------------- -END SUBROUTINE getdbwr -!- -!=== -!- -SUBROUTINE getdbrr (pos,size_of_in,target,tmp_ret_val) -!--------------------------------------------------------------------- -!- Read the required variables in the database for REALS -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: pos, size_of_in - CHARACTER(LEN=*) :: target - REAL,DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- - IF (keytype(pos) /= 2) THEN - WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target - STOP 'getdbrr' - ENDIF -!- - IF (keycompress(pos) > 0) THEN - IF ( (keycompress(pos) /= size_of_in) & - & .OR.(keymemlen(pos) /= 1) ) THEN - WRITE(*,*) & - & 'FATAL ERROR : Wrong compression length for keyword ',target - STOP 'getdbrr' - ELSE - tmp_ret_val(1:size_of_in) = realmem(keymemstart(pos)) - ENDIF - ELSE - IF (keymemlen(pos) /= size_of_in) THEN - WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target - STOP 'getdbrr' - ELSE - tmp_ret_val(1:size_of_in) = & - & realmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) - ENDIF - ENDIF -!--------------------- -END SUBROUTINE getdbrr -!- -!=== CHARACTER database INTERFACE -!- -SUBROUTINE getdbwc & - & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) -!--------------------------------------------------------------------- -!- Write the CHARACTER data into the data base -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: target - INTEGER :: target_sig,status,fileorig,size_of_in - CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- -!- -! First check if we have sufficiant space for the new key -!- - IF (nb_keys+1 > keymemsize) THEN - CALL getin_allockeys () - ENDIF -!- -! Fill out the items of the data base -!- - nb_keys = nb_keys+1 - keysig(nb_keys) = target_sig - keystr(nb_keys) = target(1:MIN(len_trim(target),30)) - keystatus(nb_keys) = status - keytype(nb_keys) = 3 - keyfromfile(nb_keys) = fileorig - keymemstart(nb_keys) = charmempos+1 - keymemlen(nb_keys) = size_of_in -!- -! Before writing the actual size lets see if we have the space -!- - IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN - CALL getin_allocmem (3,keymemlen(nb_keys)) - ENDIF -!- - charmem(keymemstart(nb_keys): & - & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & - & tmp_ret_val(1:keymemlen(nb_keys)) - charmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 -!--------------------- -END SUBROUTINE getdbwc -!- -!=== -!- -SUBROUTINE getdbrc(pos,size_of_in,target,tmp_ret_val) -!--------------------------------------------------------------------- -!- Read the required variables in the database for CHARACTER -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: pos, size_of_in - CHARACTER(LEN=*) :: target - CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- - IF (keytype(pos) /= 3) THEN - WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target - STOP 'getdbrc' - ENDIF -!- - IF (keymemlen(pos) /= size_of_in) THEN - WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target - STOP 'getdbrc' - ELSE - tmp_ret_val(1:size_of_in) = & - & charmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) - ENDIF -!--------------------- -END SUBROUTINE getdbrc -!- -!=== LOGICAL database INTERFACE -!- -SUBROUTINE getdbwl & - & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) -!--------------------------------------------------------------------- -!- Write the LOGICAL data into the data base -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: target - INTEGER :: target_sig, status, fileorig, size_of_in - LOGICAL,DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- -!- -! First check if we have sufficiant space for the new key -!- - IF (nb_keys+1 > keymemsize) THEN - CALL getin_allockeys () - ENDIF -!- -! Fill out the items of the data base -!- - nb_keys = nb_keys+1 - keysig(nb_keys) = target_sig - keystr(nb_keys) = target(1:MIN(len_trim(target),30)) - keystatus(nb_keys) = status - keytype(nb_keys) = 4 - keyfromfile(nb_keys) = fileorig - keymemstart(nb_keys) = logicmempos+1 - keymemlen(nb_keys) = size_of_in -!- -! Before writing the actual size lets see if we have the space -!- - IF (keymemstart(nb_keys)+keymemlen(nb_keys) > logicmemsize) THEN - CALL getin_allocmem (4,keymemlen(nb_keys)) - ENDIF -!- - logicmem(keymemstart(nb_keys): & - & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & - & tmp_ret_val(1:keymemlen(nb_keys)) - logicmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 -!--------------------- -END SUBROUTINE getdbwl -!- -!=== -!- -SUBROUTINE getdbrl(pos,size_of_in,target,tmp_ret_val) -!--------------------------------------------------------------------- -!- Read the required variables in the database for LOGICALS -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: pos, size_of_in - CHARACTER(LEN=*) :: target - LOGICAL,DIMENSION(:) :: tmp_ret_val -!--------------------------------------------------------------------- - IF (keytype(pos) /= 4) THEN - WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target - STOP 'getdbrl' - ENDIF -!- - IF (keymemlen(pos) /= size_of_in) THEN - WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target - STOP 'getdbrl' - ELSE - tmp_ret_val(1:size_of_in) = & - & logicmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) - ENDIF -!--------------------- -END SUBROUTINE getdbrl -!- -!=== -!- -SUBROUTINE getin_allockeys () -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER,ALLOCATABLE :: tmp_int(:) - CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:) -!- - INTEGER :: ier -!--------------------------------------------------------------------- -!- -! Either nothing exists in these arrays and it is easy to do -!- - IF (keymemsize == 0) THEN -!- - ALLOCATE(keysig(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keysig to size ', & - & memslabs - STOP - ENDIF -!- - ALLOCATE(keystr(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keystr to size ', & - & memslabs - STOP - ENDIF -!- - ALLOCATE(keystatus(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keystatus to size ', & - & memslabs - STOP - ENDIF -!- - ALLOCATE(keytype(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keytype to size ', & - & memslabs - STOP - ENDIF -!- - ALLOCATE(keycompress(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keycompress to size ', & - & memslabs - STOP - ENDIF -!- - ALLOCATE(keyfromfile(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keyfromfile to size ', & - & memslabs - STOP - ENDIF -!- - ALLOCATE(keymemstart(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keymemstart to size ', & - & memslabs - STOP - ENDIF -!- - ALLOCATE(keymemlen(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keymemlen to size ', & - & memslabs - STOP - ENDIF -!- - nb_keys = 0 - keymemsize = memslabs - keycompress(:) = -1 -!- - ELSE -!- -!-- There is something already in the memory, -!-- we need to transfer and reallocate. -!- - ALLOCATE(tmp_str(keymemsize),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate tmp_str to size ', & - & keymemsize - STOP - ENDIF -!- - ALLOCATE(tmp_int(keymemsize),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate tmp_int to size ', & - & keymemsize - STOP - ENDIF -!- - tmp_int(1:keymemsize) = keysig(1:keymemsize) - DEALLOCATE(keysig) - ALLOCATE(keysig(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keysig to size ', & - & keymemsize+memslabs - STOP - ENDIF - keysig(1:keymemsize) = tmp_int(1:keymemsize) -!- - tmp_str(1:keymemsize) = keystr(1:keymemsize) - DEALLOCATE(keystr) - ALLOCATE(keystr(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keystr to size ', & - & keymemsize+memslabs - STOP - ENDIF - keystr(1:keymemsize) = tmp_str(1:keymemsize) -!- - tmp_int(1:keymemsize) = keystatus(1:keymemsize) - DEALLOCATE(keystatus) - ALLOCATE(keystatus(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keystatus to size ', & - & keymemsize+memslabs - STOP - ENDIF - keystatus(1:keymemsize) = tmp_int(1:keymemsize) -!- - tmp_int(1:keymemsize) = keytype(1:keymemsize) - DEALLOCATE(keytype) - ALLOCATE(keytype(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keytype to size ', & - & keymemsize+memslabs - STOP - ENDIF - keytype(1:keymemsize) = tmp_int(1:keymemsize) -!- - tmp_int(1:keymemsize) = keycompress(1:keymemsize) - DEALLOCATE(keycompress) - ALLOCATE(keycompress(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keycompress to size ', & - & keymemsize+memslabs - STOP - ENDIF - keycompress(:) = -1 - keycompress(1:keymemsize) = tmp_int(1:keymemsize) -!- - tmp_int(1:keymemsize) = keyfromfile(1:keymemsize) - DEALLOCATE(keyfromfile) - ALLOCATE(keyfromfile(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keyfromfile to size ', & - & keymemsize+memslabs - STOP - ENDIF - keyfromfile(1:keymemsize) = tmp_int(1:keymemsize) -!- - tmp_int(1:keymemsize) = keymemstart(1:keymemsize) - DEALLOCATE(keymemstart) - ALLOCATE(keymemstart(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keymemstart to size ', & - & keymemsize+memslabs - STOP - ENDIF - keymemstart(1:keymemsize) = tmp_int(1:keymemsize) -!- - tmp_int(1:keymemsize) = keymemlen(1:keymemsize) - DEALLOCATE(keymemlen) - ALLOCATE(keymemlen(keymemsize+memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allockeys : Can not allocate keymemlen to size ', & - & keymemsize+memslabs - STOP - ENDIF - keymemlen(1:keymemsize) = tmp_int(1:keymemsize) -!- - keymemsize = keymemsize+memslabs -!- - DEALLOCATE(tmp_int) - DEALLOCATE(tmp_str) - ENDIF -!----------------------------- -END SUBROUTINE getin_allockeys -!- -!=== -!- -SUBROUTINE getin_allocmem (type,len_wanted) -!--------------------------------------------------------------------- -!- Allocate the memory of the data base for all 4 types of memory -!- -!- 1 = INTEGER -!- 2 = REAL -!- 3 = CHAR -!- 4 = LOGICAL -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: type, len_wanted -!- - INTEGER,ALLOCATABLE :: tmp_int(:) - CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) - REAL,ALLOCATABLE :: tmp_real(:) - LOGICAL,ALLOCATABLE :: tmp_logic(:) - INTEGER :: ier -!--------------------------------------------------------------------- - SELECT CASE (type) - CASE(1) - IF (intmemsize == 0) THEN - ALLOCATE(intmem(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate db-memory intmem to ', & - & memslabs - STOP - ENDIF - intmemsize=memslabs - ELSE - ALLOCATE(tmp_int(intmemsize),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate tmp_int to ', & - & intmemsize - STOP - ENDIF - tmp_int(1:intmemsize) = intmem(1:intmemsize) - DEALLOCATE(intmem) - ALLOCATE(intmem(intmemsize+MAX(memslabs,len_wanted)),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to re-allocate db-memory intmem to ', & - & intmemsize+MAX(memslabs,len_wanted) - STOP - ENDIF - intmem(1:intmemsize) = tmp_int(1:intmemsize) - intmemsize = intmemsize+MAX(memslabs,len_wanted) - DEALLOCATE(tmp_int) - ENDIF - CASE(2) - IF (realmemsize == 0) THEN - ALLOCATE(realmem(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate db-memory realmem to ', & - & memslabs - STOP - ENDIF - realmemsize = memslabs - ELSE - ALLOCATE(tmp_real(realmemsize),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate tmp_real to ', & - & realmemsize - STOP - ENDIF - tmp_real(1:realmemsize) = realmem(1:realmemsize) - DEALLOCATE(realmem) - ALLOCATE(realmem(realmemsize+MAX(memslabs,len_wanted)),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to re-allocate db-memory realmem to ', & - & realmemsize+MAX(memslabs,len_wanted) - STOP - ENDIF - realmem(1:realmemsize) = tmp_real(1:realmemsize) - realmemsize = realmemsize+MAX(memslabs,len_wanted) - DEALLOCATE(tmp_real) - ENDIF - CASE(3) - IF (charmemsize == 0) THEN - ALLOCATE(charmem(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate db-memory charmem to ', & - & memslabs - STOP - ENDIF - charmemsize = memslabs - ELSE - ALLOCATE(tmp_char(charmemsize),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate tmp_char to ', & - & charmemsize - STOP - ENDIF - tmp_char(1:charmemsize) = charmem(1:charmemsize) - DEALLOCATE(charmem) - ALLOCATE(charmem(charmemsize+MAX(memslabs,len_wanted)),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to re-allocate db-memory charmem to ', & - & charmemsize+MAX(memslabs,len_wanted) - STOP - ENDIF - charmem(1:charmemsize) = tmp_char(1:charmemsize) - charmemsize = charmemsize+MAX(memslabs,len_wanted) - DEALLOCATE(tmp_char) - ENDIF - CASE(4) - IF (logicmemsize == 0) THEN - ALLOCATE(logicmem(memslabs),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate db-memory logicmem to ', & - & memslabs - STOP - ENDIF - logicmemsize = memslabs - ELSE - ALLOCATE(tmp_logic(logicmemsize),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to allocate tmp_logic to ', & - & logicmemsize - STOP - ENDIF - tmp_logic(1:logicmemsize) = logicmem(1:logicmemsize) - DEALLOCATE(logicmem) - ALLOCATE(logicmem(logicmemsize+MAX(memslabs,len_wanted)),stat=ier) - IF (ier /= 0) THEN - WRITE(*,*) & - & 'getin_allocmem : Unable to re-allocate db-memory logicmem to ', & - & logicmemsize+MAX(memslabs,len_wanted) - STOP - ENDIF - logicmem(1:logicmemsize) = tmp_logic(1:logicmemsize) - logicmemsize = logicmemsize+MAX(memslabs,len_wanted) - DEALLOCATE(tmp_logic) - ENDIF - CASE DEFAULT - WRITE(*,*) 'getin_allocmem : Unknown type : ',type - STOP - END SELECT -!---------------------------- -END SUBROUTINE getin_allocmem -!- -!=== -!- -SUBROUTINE getin_dump (fileprefix) -!--------------------------------------------------------------------- -!- This subroutine will dump the content of the database into file -!- which has the same format as the run.def. The idea is that the user -!- can see which parameters were used and re-use the file for another -!- run. -!- -!- The argument file allows the user to change the name of the file -!- in which the data will be archived -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(*),OPTIONAL :: fileprefix -!- - CHARACTER(LEN=80) :: usedfileprefix = "used" - INTEGER :: ikey,if,iff,iv - CHARACTER(LEN=3) :: tmp3 - CHARACTER(LEN=100) :: tmp_str, used_filename - LOGICAL :: check = .FALSE. -!--------------------------------------------------------------------- - IF (PRESENT(fileprefix)) THEN - usedfileprefix = fileprefix(1:MIN(len_trim(fileprefix),80)) - ENDIF -!- - DO if=1,nbfiles -!--- - used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if)) - IF (check) THEN - WRITE(*,*) & - & 'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if - WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys - ENDIF - OPEN(unit=76,file=used_filename) -!- -!-- If this is the first file we need to add the list -!-- of file which belong to it -!- - IF ( (if == 1) .AND. (nbfiles > 1) ) THEN - WRITE(76,*) '# ' - WRITE(76,*) '# This file is linked to the following files :' - WRITE(76,*) '# ' - DO iff=2,nbfiles - WRITE(76,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) - ENDDO - WRITE(76,*) '# ' - ENDIF -!--- - DO ikey=1,nb_keys -!- -!---- Is this key form this file ? -!- - IF (keyfromfile(ikey) == if) THEN -!- -!---- Write some comments -!- - WRITE(76,*) '#' - SELECT CASE (keystatus(ikey)) - CASE(1) - WRITE(76,*) '# Values of ', & - & TRIM(keystr(ikey)),' comes from the run.def.' - CASE(2) - WRITE(76,*) '# Values of ', & - & TRIM(keystr(ikey)),' are all defaults.' - CASE(3) - WRITE(76,*) '# Values of ', & - & TRIM(keystr(ikey)),' are a mix of run.def and defaults.' - CASE DEFAULT - WRITE(76,*) '# Dont know from where the value of ', & - & TRIM(keystr(ikey)),' comes.' - END SELECT - WRITE(76,*) '#' -!- -!---- Write the values -!- - SELECT CASE (keytype(ikey)) -!- - CASE(1) - IF (keymemlen(ikey) == 1) THEN - IF (keycompress(ikey) < 0) THEN - WRITE(76,*) & - & TRIM(keystr(ikey)),' = ',intmem(keymemstart(ikey)) - ELSE - WRITE(76,*) & - & TRIM(keystr(ikey)),' = ',keycompress(ikey), & - & ' * ',intmem(keymemstart(ikey)) - ENDIF - ELSE - DO iv=0,keymemlen(ikey)-1 - WRITE(tmp3,'(I3.3)') iv+1 - WRITE(76,*) & - & TRIM(keystr(ikey)),'__',tmp3, & - & ' = ',intmem(keymemstart(ikey)+iv) - ENDDO - ENDIF -!- - CASE(2) - IF (keymemlen(ikey) == 1) THEN - IF (keycompress(ikey) < 0) THEN - WRITE(76,*) & - & TRIM(keystr(ikey)),' = ',realmem(keymemstart(ikey)) - ELSE - WRITE(76,*) & - & TRIM(keystr(ikey)),' = ',keycompress(ikey),& - & ' * ',realmem(keymemstart(ikey)) - ENDIF - ELSE - DO iv=0,keymemlen(ikey)-1 - WRITE(tmp3,'(I3.3)') iv+1 - WRITE(76,*) & - & TRIM(keystr(ikey)),'__',tmp3, & - & ' = ',realmem(keymemstart(ikey)+iv) - ENDDO - ENDIF - CASE(3) - IF (keymemlen(ikey) == 1) THEN - tmp_str = charmem(keymemstart(ikey)) - WRITE(76,*) TRIM(keystr(ikey)),' = ',TRIM(tmp_str) - ELSE - DO iv=0,keymemlen(ikey)-1 - WRITE(tmp3,'(I3.3)') iv+1 - tmp_str = charmem(keymemstart(ikey)+iv) - WRITE(76,*) & - & TRIM(keystr(ikey)),'__',tmp3,' = ',TRIM(tmp_str) - ENDDO - ENDIF - CASE(4) - IF (keymemlen(ikey) == 1) THEN - IF (logicmem(keymemstart(ikey))) THEN - WRITE(76,*) TRIM(keystr(ikey)),' = TRUE ' - ELSE - WRITE(76,*) TRIM(keystr(ikey)),' = FALSE ' - ENDIF - ELSE - DO iv=0,keymemlen(ikey)-1 - WRITE(tmp3,'(I3.3)') iv+1 - IF (logicmem(keymemstart(ikey)+iv)) THEN - WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = TRUE ' - ELSE - WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = FALSE ' - ENDIF - ENDDO - ENDIF -!- - CASE DEFAULT - WRITE(*,*) & - & 'FATAL ERROR : Unknown type for variable ', & - & TRIM(keystr(ikey)) - STOP 'getin_dump' - END SELECT - ENDIF - ENDDO -!- - CLOSE(unit=76) -!- - ENDDO -!------------------------ -END SUBROUTINE getin_dump -!- -!=== -!- -END MODULE ioipsl_getincom Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/ioipsl_stringop.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/ioipsl_stringop.F90 (revision 1180) +++ (revision ) @@ -1,256 +1,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Module and routines in this file are taken from IOIPSL -! files stringop.f90 -! Module names has been changed to avoid problems -! if compiling model with IOIPSL library -! Ehouarn - March 2009 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE ioipsl_stringop -!--------------------------------------------------------------------- -!- - INTEGER, DIMENSION(30) :: & - & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, & - & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/) -!- -!--------------------------------------------------------------------- -CONTAINS -!= - SUBROUTINE cmpblank (str) -!--------------------------------------------------------------------- -!- -!--------------------------------------------------------------------- - CHARACTER(LEN=*),INTENT(inout) :: str -!- - INTEGER :: lcc,ipb -!--------------------------------------------------------------------- - lcc = LEN_TRIM(str) - ipb = 1 - DO - IF (ipb >= lcc) EXIT - IF (str(ipb:ipb+1) == ' ') THEN - str(ipb+1:) = str(ipb+2:lcc) - lcc = lcc-1 - ELSE - ipb = ipb+1 - ENDIF - ENDDO -!------------------------- - END SUBROUTINE cmpblank -!= - INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) -!--------------------------------------------------------------------- -!- Finds number of occurences of c_r in c_c -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*),INTENT(in) :: c_c - INTEGER,INTENT(IN) :: l_c - CHARACTER(LEN=*),INTENT(in) :: c_r - INTEGER,INTENT(IN) :: l_r -!- - INTEGER :: ipos,indx,ires -!--------------------------------------------------------------------- - cntpos = 0 - ipos = 1 - DO - indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) - IF (indx > 0) THEN - cntpos = cntpos+1 - ipos = ipos+indx+l_r-1 - ELSE - EXIT - ENDIF - ENDDO -!--------------------- - END FUNCTION cntpos -!= - INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) -!--------------------------------------------------------------------- -!- Finds position of c_r in c_c -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*),INTENT(in) :: c_c - INTEGER,INTENT(IN) :: l_c - CHARACTER(LEN=*),INTENT(in) :: c_r - INTEGER,INTENT(IN) :: l_r -!--------------------------------------------------------------------- - findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) - IF (findpos == 0) findpos=-1 -!---------------------- - END FUNCTION findpos -!= - SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos) -!--------------------------------------------------------------------- -!- This subroutine looks for a string in a table -!--------------------------------------------------------------------- -!- INPUT -!- nb_str : length of table -!- str_tab : Table of strings -!- str_len_tab : Table of string-length -!- str : Target we are looking for -!- OUTPUT -!- pos : -1 if str not found, else value in the table -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: nb_str - CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab - INTEGER,DIMENSION(nb_str) :: str_len_tab - CHARACTER(LEN=*) :: str - INTEGER :: pos -!- - INTEGER :: i,il -!--------------------------------------------------------------------- - pos = -1 - il = LEN_TRIM(str) - IF ( nb_str > 0 ) THEN - DO i=1,nb_str - IF ( (INDEX(str_tab(i),str(1:il)) > 0) & - .AND.(str_len_tab(i) == il) ) THEN - pos = i - EXIT - ENDIF - ENDDO - ENDIF -!------------------------- - END SUBROUTINE find_str -!= - SUBROUTINE nocomma (str) -!--------------------------------------------------------------------- -!- -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: str -!- - INTEGER :: i -!--------------------------------------------------------------------- - DO i=1,LEN_TRIM(str) - IF (str(i:i) == ',') str(i:i) = ' ' - ENDDO -!------------------------ - END SUBROUTINE nocomma -!= - SUBROUTINE strlowercase (str) -!--------------------------------------------------------------------- -!- Converts a string into lowercase -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: str -!- - INTEGER :: i,ic -!--------------------------------------------------------------------- - DO i=1,LEN_TRIM(str) - ic = IACHAR(str(i:i)) - IF ( (ic >= 65) .AND. (ic <= 90) ) str(i:i) = ACHAR(ic+32) - ENDDO -!----------------------------- - END SUBROUTINE strlowercase -!= - SUBROUTINE struppercase (str) -!--------------------------------------------------------------------- -!- Converts a string into uppercase -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: str -!- - INTEGER :: i,ic -!--------------------------------------------------------------------- - DO i=1,LEN_TRIM(str) - ic = IACHAR(str(i:i)) - IF ( (ic >= 97) .AND. (ic <= 122) ) str(i:i) = ACHAR(ic-32) - ENDDO -!----------------------------- - END SUBROUTINE struppercase -!= -!------------------ - SUBROUTINE gensig (str, sig) -!--------------------------------------------------------------------- -!- Generate a signature from the first 30 characters of the string -!- This signature is not unique and thus when one looks for the -!- one needs to also verify the string. -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - CHARACTER(LEN=*) :: str - INTEGER :: sig -!- - INTEGER :: i -!--------------------------------------------------------------------- - sig = 0 - DO i=1,MIN(len_trim(str),30) - sig = sig + prime(i)*IACHAR(str(i:i)) - ENDDO -!----------------------------- - END SUBROUTINE gensig -!= -!------------------ - SUBROUTINE find_sig (nb_sig, str_tab, str, sig_tab, sig, pos) -!--------------------------------------------------------------------- -!- Find the string signature in a list of signatures -!--------------------------------------------------------------------- -!- INPUT -!- nb_sig : length of table of signatures -!- str_tab : Table of strings -!- str : Target string we are looking for -!- sig_tab : Table of signatures -!- sig : Target signature we are looking for -!- OUTPUT -!- pos : -1 if str not found, else value in the table -!--------------------------------------------------------------------- - IMPLICIT NONE -!- - INTEGER :: nb_sig - CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab - CHARACTER(LEN=*) :: str - INTEGER, DIMENSION(nb_sig) :: sig_tab - INTEGER :: sig -!- - INTEGER :: pos - INTEGER, DIMENSION(nb_sig) :: loczeros -!- - INTEGER :: il, len - INTEGER, DIMENSION(1) :: minpos -!--------------------------------------------------------------------- -!- - pos = -1 - il = LEN_TRIM(str) -!- - IF ( nb_sig > 0 ) THEN - ! - loczeros = ABS(sig_tab(1:nb_sig)-sig) - ! - IF ( COUNT(loczeros < 1) == 1 ) THEN - ! - minpos = MINLOC(loczeros) - len = LEN_TRIM(str_tab(minpos(1))) - IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & - .AND.(len == il) ) THEN - pos = minpos(1) - ENDIF - ! - ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN - ! - DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) - minpos = MINLOC(loczeros) - len = LEN_TRIM(str_tab(minpos(1))) - IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & - .AND.(len == il) ) THEN - pos = minpos(1) - ELSE - loczeros(minpos(1)) = 99999 - ENDIF - ENDDO - ! - ENDIF - ! - ENDIF -!- - END SUBROUTINE find_sig -!= -!------------------ -END MODULE ioipsl_stringop