Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/initdynav.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/initdynav.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/initdynav.F (revision 1186) @@ -1,11 +1,11 @@ ! -! $Header$ +! $Id$ ! -c -c subroutine initdynav(infile,day0,anne0,tstep,t_ops,t_wrt . ,fileid) +#ifdef CPP_IOIPSL USE IOIPSL +#endif USE infotrac, ONLY : nqtot, ttext @@ -48,4 +48,5 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C Arguments @@ -55,8 +56,10 @@ real tstep, t_ops, t_wrt integer fileid - integer thoriid, zvertiid +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work C Variables locales C + integer thoriid, zvertiid integer tau0 real zjulian @@ -161,4 +164,10 @@ C call histend(fileid) +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"initdynav: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/initfluxsto.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/initfluxsto.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/initfluxsto.F (revision 1186) @@ -1,4 +1,4 @@ ! -! $Header$ +! $Id$ ! subroutine initfluxsto @@ -6,6 +6,7 @@ . fileid,filevid,filedid) +#ifdef CPP_IOIPSL USE IOIPSL - +#endif implicit none @@ -47,16 +48,17 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C Arguments C character*(*) infile - integer*4 itau real tstep, t_ops, t_wrt integer fileid, filevid,filedid - integer ndex(1) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C real nivd(1) - -C Variables locales -C integer tau0 real zjulian @@ -222,4 +224,10 @@ endif +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"initfluxsto: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/inithist.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/inithist.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/inithist.F (revision 1186) @@ -1,9 +1,11 @@ ! -! $Header$ +! $Id$ ! subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,fileid, . filevid) +#ifdef CPP_IOIPSL USE IOIPSL +#endif USE infotrac, ONLY : nqtot, ttext @@ -48,4 +50,5 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C Arguments @@ -56,4 +59,6 @@ integer fileid, filevid +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work C Variables locales C @@ -181,4 +186,10 @@ call histend(fileid) call histend(filevid) +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"inithist: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_errioipsl.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_errioipsl.F90 (revision 1186) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_errioipsl.F90 (revision 1186) @@ -0,0 +1,219 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_errioipsl +!- +!$Id: errioipsl.f90 386 2008-09-04 08:38:48Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg +!- + INTEGER :: n_l=6, ilv_cur=0, ilv_max=0 + LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE. +!- +!=== +CONTAINS +!=== +SUBROUTINE ipslnlf (new_number,old_number) +!!-------------------------------------------------------------------- +!! The "ipslnlf" routine allows to know and modify +!! the current logical number for the messages. +!! +!! SUBROUTINE ipslnlf (new_number,old_number) +!! +!! Optional INPUT argument +!! +!! (I) new_number : new logical number of the file +!! +!! Optional OUTPUT argument +!! +!! (I) old_number : current logical number of the file +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(IN) :: new_number + INTEGER,OPTIONAL,INTENT(OUT) :: old_number +!--------------------------------------------------------------------- + IF (PRESENT(old_number)) THEN + old_number = n_l + ENDIF + IF (PRESENT(new_number)) THEN + n_l = new_number + ENDIF +!--------------------- +END SUBROUTINE ipslnlf +!=== +SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!! The "ipslerr" routine +!! allows to handle the messages to the user. +!! +!! INPUT +!! +!! plev : Category of message to be reported to the user +!! 1 = Note to the user +!! 2 = Warning to the user +!! 3 = Fatal error +!! pcname : Name of subroutine which has called ipslerr +!! pstr1 +!! pstr2 : Strings containing the explanations to the user +!! pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + ilv_cur = plev + ilv_max = MAX(ilv_max,plev) + WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3) + ENDIF + IF ( (plev == 3).AND.lact_mode) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE ipslerr +!=== +SUBROUTINE ipslerr_act (new_mode,old_mode) +!!-------------------------------------------------------------------- +!! The "ipslerr_act" routine allows to know and modify +!! the current "action mode" for the error messages, +!! and reinitialize the error level values. +!! +!! SUBROUTINE ipslerr_act (new_mode,old_mode) +!! +!! Optional INPUT argument +!! +!! (I) new_mode : new error action mode +!! .TRUE. -> STOP in case of fatal error +!! .FALSE. -> CONTINUE in case of fatal error +!! +!! Optional OUTPUT argument +!! +!! (I) old_mode : current error action mode +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_mode + LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode +!--------------------------------------------------------------------- + IF (PRESENT(old_mode)) THEN + old_mode = lact_mode + ENDIF + IF (PRESENT(new_mode)) THEN + lact_mode = new_mode + ENDIF + ilv_cur = 0 + ilv_max = 0 +!------------------------- +END SUBROUTINE ipslerr_act +!=== +SUBROUTINE ipslerr_inq (current_level,maximum_level) +!!-------------------------------------------------------------------- +!! The "ipslerr_inq" routine allows to know +!! the current level of the error messages +!! and the maximum level encountered since the +!! last call to "ipslerr_act". +!! +!! SUBROUTINE ipslerr_inq (current_level,maximum_level) +!! +!! Optional OUTPUT argument +!! +!! (I) current_level : current error level +!! (I) maximum_level : maximum error level +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level +!--------------------------------------------------------------------- + IF (PRESENT(current_level)) THEN + current_level = ilv_cur + ENDIF + IF (PRESENT(maximum_level)) THEN + maximum_level = ilv_max + ENDIF +!------------------------- +END SUBROUTINE ipslerr_inq +!=== +SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!- INPUT +!- plev : Category of message to be reported to the user +!- 1 = Note to the user +!- 2 = Warning to the user +!- 3 = Fatal error +!- pcname : Name of subroutine which has called histerr +!- pstr1 +!- pstr2 : String containing the explanations to the user +!- pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + WRITE(*,'(" ")') + WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(*,'(" --> ",A)') pstr1 + WRITE(*,'(" --> ",A)') pstr2 + WRITE(*,'(" --> ",A)') pstr3 + ENDIF + IF (plev == 3) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE histerr +!=== +SUBROUTINE ipsldbg (new_status,old_status) +!!-------------------------------------------------------------------- +!! The "ipsldbg" routine +!! allows to activate or deactivate the debug, +!! and to know the current status of the debug. +!! +!! SUBROUTINE ipsldbg (new_status,old_status) +!! +!! Optional INPUT argument +!! +!! (L) new_status : new status of the debug +!! +!! Optional OUTPUT argument +!! +!! (L) old_status : current status of the debug +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_status + LOGICAL,OPTIONAL,INTENT(OUT) :: old_status +!--------------------------------------------------------------------- + IF (PRESENT(old_status)) THEN + old_status = ioipsl_debug + ENDIF + IF (PRESENT(new_status)) THEN + ioipsl_debug = new_status + ENDIF +!--------------------- +END SUBROUTINE ipsldbg +!=== +!------------------- +END MODULE ioipsl_errioipsl Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_getincom.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_getincom.F90 (revision 1186) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_getincom.F90 (revision 1186) @@ -0,0 +1,1980 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_getincom +!- +!$Id: getincom.f90 536 2009-01-30 11:46:27Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +USE ioipsl_errioipsl, ONLY : ipslerr +USE ioipsl_stringop, & + & ONLY : nocomma,cmpblank,strlowercase +!- +IMPLICIT NONE +!- +PRIVATE +PUBLIC :: getin, getin_dump +!- +INTERFACE getin +!!-------------------------------------------------------------------- +!! The "getin" routines get a variable. +!! We first check if we find it in the database +!! and if not we get it from the run.def file. +!! +!! SUBROUTINE getin (target,ret_val) +!! +!! INPUT +!! +!! (C) target : Name of the variable +!! +!! OUTPUT +!! +!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain +!! that will contain the (standard) +!! integer/real/character/logical values +!!-------------------------------------------------------------------- + MODULE PROCEDURE getinrs, getinr1d, getinr2d, & + & getinis, getini1d, getini2d, & + & getincs, getinc1d, getinc2d, & + & getinls, getinl1d, getinl2d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "getin_dump" routine will dump the content of the database +!! into a file which has the same format as the run.def file. +!! The idea is that the user can see which parameters were used +!! and re-use the file for another run. +!! +!! SUBROUTINE getin_dump (fileprefix) +!! +!! OPTIONAL INPUT argument +!! +!! (C) fileprefix : allows the user to change the name of the file +!! in which the data will be archived +!!-------------------------------------------------------------------- +!- + INTEGER,PARAMETER :: max_files=100 + CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist + INTEGER,SAVE :: nbfiles +!- + INTEGER,PARAMETER :: i_txtslab=1000,l_n=30 + INTEGER,SAVE :: nb_lines,i_txtsize=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier + CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline +!- + INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15 + CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)' +!- +! The data base of parameters +!- + INTEGER,PARAMETER :: memslabs=200 + INTEGER,PARAMETER :: compress_lim=20 +!- + INTEGER,SAVE :: nb_keys=0 + INTEGER,SAVE :: keymemsize=0 +!- +! keystr definition +! name of a key +!- +! keystatus definition +! keystatus = 1 : Value comes from run.def +! keystatus = 2 : Default value is used +! keystatus = 3 : Some vector elements were taken from default +!- +! keytype definition +! keytype = 1 : Integer +! keytype = 2 : Real +! keytype = 3 : Character +! keytype = 4 : Logical +!- + INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4 +!- +! Allow compression for keys (only for integer and real) +! keycompress < 0 : not compressed +! keycompress > 0 : number of repeat of the value +!- +TYPE :: t_key + CHARACTER(LEN=l_n) :: keystr + INTEGER :: keystatus, keytype, keycompress, & + & keyfromfile, keymemstart, keymemlen +END TYPE t_key +!- + TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab +!- + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem + INTEGER,SAVE :: i_memsize=0, i_mempos=0 + REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem + INTEGER,SAVE :: r_memsize=0, r_mempos=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem + INTEGER,SAVE :: c_memsize=0, c_mempos=0 + LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem + INTEGER,SAVE :: l_memsize=0, l_mempos=0 +!- +CONTAINS +!- +!=== INTEGER INTERFACE +!- +SUBROUTINE getinis (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: ret_val +!- + INTEGER,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,i_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinis +!=== +SUBROUTINE getini1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=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) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:,:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=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 +!- +!=== REAL INTERFACE +!- +SUBROUTINE getinrs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL :: ret_val +!- + REAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,r_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinrs +!=== +SUBROUTINE getinr1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=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) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:,:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=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 +!- +!=== CHARACTER INTERFACE +!- +SUBROUTINE getincs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,c_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getincs +!=== +SUBROUTINE getinc1d (target,ret_val) +!--------------------------------------------------------------------- + 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 :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=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) +!--------------------------------------------------------------------- + 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 :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=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 +!- +!=== LOGICAL INTERFACE +!- +SUBROUTINE getinls (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL :: ret_val +!- + LOGICAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,l_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinls +!=== +SUBROUTINE getinl1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=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) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:,:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,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 +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=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 +!- +!=== Generic file/database INTERFACE +!- +SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Subroutine that will extract from the file the values +!- attributed to the keyword target +!- +!- (C) target : target for which we will look in the file +!- (I) status : tells us from where we obtained the data +!- (I) fileorig : index of the file from which the key comes +!- (I) i_val(:) : INTEGER(nb_to_ret) values +!- (R) r_val(:) : REAL(nb_to_ret) values +!- (L) l_val(:) : LOGICAL(nb_to_ret) values +!- (C) c_val(:) : CHARACTER(nb_to_ret) values +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,INTENT(OUT) :: status,fileorig + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=80) :: str_READ,str_READ_lower + CHARACTER(LEN=9) :: c_vtyp + LOGICAL,DIMENSION(:),ALLOCATABLE :: found + LOGICAL :: def_beha,compressed + CHARACTER(LEN=10) :: c_fmt + INTEGER :: i_cmpval + REAL :: r_cmpval + INTEGER :: ipos_tr,ipos_fl +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + SELECT CASE (k_typ) + CASE(k_i) + nb_to_ret = SIZE(i_val) + CASE(k_r) + nb_to_ret = SIZE(r_val) + CASE(k_c) + nb_to_ret = SIZE(c_val) + CASE(k_l) + nb_to_ret = SIZE(l_val) + CASE DEFAULT + CALL ipslerr (3,'get_fil', & + & 'Internal error','Unknown type of data',' ') + END SELECT +!- +! Read the file(s) + CALL getin_read +!- +! Allocate and initialize the memory we need + ALLOCATE(found(nb_to_ret)) + found(:) = .FALSE. +!- +! See what we find in the files read + DO it=1,nb_to_ret +!--- +!-- First try the target as it is + CALL get_findkey (2,target,pos) +!--- +!-- Another try +!--- + IF (pos < 0) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + CALL get_findkey (2,TRIM(target)//'__'//cnt,pos) + ENDIF +!--- +!-- 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 = ADJUSTL(fichier(pos)) + str_READ_lower = str_READ + CALL strlowercase (str_READ_lower) +!----- + IF ( (TRIM(str_READ_lower) == 'def') & + & .OR.(TRIM(str_READ_lower) == 'default') ) THEN + def_beha = .TRUE. + ELSE + def_beha = .FALSE. + len_str = LEN_TRIM(str_READ) + io_err = 0 + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str + READ (UNIT=str_READ(1:len_str), & + & FMT=c_fmt,IOSTAT=io_err) i_val(it) + CASE(k_r) + READ (UNIT=str_READ(1:len_str), & + & FMT=*,IOSTAT=io_err) r_val(it) + CASE(k_c) + c_val(it) = str_READ(1:len_str) + CASE(k_l) + ipos_tr = -1 + ipos_fl = -1 + ipos_tr = MAX(INDEX(str_READ_lower,'tru'), & + & INDEX(str_READ_lower,'y')) + ipos_fl = MAX(INDEX(str_READ_lower,'fal'), & + & INDEX(str_READ_lower,'n')) + IF (ipos_tr > 0) THEN + l_val(it) = .TRUE. + ELSE IF (ipos_fl > 0) THEN + l_val(it) = .FALSE. + ELSE + io_err = 100 + ENDIF + END SELECT + IF (io_err /= 0) THEN + CALL ipslerr (3,'get_fil', & + & 'Target '//TRIM(target), & + & 'is not of '//TRIM(c_vtyp)//' type',' ') + ENDIF + ENDIF +!----- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!------- +!------ Is this the value of a compressed field ? + compressed = (compline(pos) > 0) + IF (compressed) THEN + IF (compline(pos) /= nb_to_ret) THEN + CALL ipslerr (2,'get_fil', & + & 'For key '//TRIM(target)//' we have a compressed field', & + & 'which does not have the right size.', & + & 'We will try to fix that.') + ENDIF + IF (k_typ == k_i) THEN + i_cmpval = i_val(it) + ELSE IF (k_typ == k_r) THEN + r_cmpval = r_val(it) + ENDIF + ENDIF + ENDIF + ELSE + found(it) = .FALSE. + def_beha = .FALSE. + compressed = .FALSE. + ENDIF + ENDDO +!- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!--- +!-- 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 + IF (k_typ == k_i) THEN + i_val(it) = i_cmpval + ELSE IF (k_typ == k_r) THEN + ENDIF + found(it) = .TRUE. + ENDIF + ENDDO + ENDIF + ENDIF +!- +! Now we set 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 (status_cnt <= max_msgs) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & + & ADVANCE='NO') TRIM(target) + IF (nb_to_ret > 1) THEN + WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') + WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it + ENDIF + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=*,FMT=*) "=",i_val(it) + CASE(k_r) + WRITE (UNIT=*,FMT=*) "=",r_val(it) + CASE(k_c) + WRITE (UNIT=*,FMT=*) "=",c_val(it) + CASE(k_l) + WRITE (UNIT=*,FMT=*) "=",l_val(it) + END SELECT + ELSE IF (status_cnt == max_msgs+1) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)') + ENDIF + ENDIF + ENDDO +!--- + IF (status_cnt == 0) THEN + status = 1 + ELSE IF (status_cnt == nb_to_ret) THEN + status = 2 + ELSE + status = 3 + ENDIF + ENDIF +! Deallocate the memory + DEALLOCATE(found) +!--------------------- +END SUBROUTINE get_fil +!=== +SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Read the required variable in the database +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: pos,size_of_in + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,k_beg,k_end + CHARACTER(LEN=9) :: c_vtyp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_rdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- + IF (key_tab(pos)%keytype /= k_typ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong data type for keyword '//TRIM(target), & + & '(NOT '//TRIM(c_vtyp)//')',' ') + ENDIF +!- + IF (key_tab(pos)%keycompress > 0) THEN + IF ( (key_tab(pos)%keycompress /= size_of_in) & + & .OR.(key_tab(pos)%keymemlen /= 1) ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong compression length','for keyword '//TRIM(target),' ') + ELSE + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart) + CASE(k_r) + r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart) + END SELECT + ENDIF + ELSE + IF (key_tab(pos)%keymemlen /= size_of_in) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong array length','for keyword '//TRIM(target),' ') + ELSE + k_beg = key_tab(pos)%keymemstart + k_end = k_beg+key_tab(pos)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(k_beg:k_end) + CASE(k_r) + r_val(1:size_of_in) = r_mem(k_beg:k_end) + CASE(k_c) + c_val(1:size_of_in) = c_mem(k_beg:k_end) + CASE(k_l) + l_val(1:size_of_in) = l_mem(k_beg:k_end) + END SELECT + ENDIF + ENDIF +!--------------------- +END SUBROUTINE get_rdb +!=== +SUBROUTINE get_wdb & + & (target,status,fileorig,size_of_in, & + & i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Write data into the data base +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: status,fileorig,size_of_in + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ + CHARACTER(LEN=9) :: c_vtyp + INTEGER :: k_mempos,k_memsize,k_beg,k_end + LOGICAL :: l_cmp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_wdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- +! First check if we have sufficiant space for the new key + IF (nb_keys+1 > keymemsize) THEN + CALL getin_allockeys () + ENDIF +!- + SELECT CASE (k_typ) + CASE(k_i) + k_mempos = i_mempos; k_memsize = i_memsize; + l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_r) + k_mempos = r_mempos; k_memsize = r_memsize; + l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_c) + k_mempos = c_mempos; k_memsize = c_memsize; + l_cmp = .FALSE. + CASE(k_l) + k_mempos = l_mempos; k_memsize = l_memsize; + l_cmp = .FALSE. + END SELECT +!- +! Fill out the items of the data base + nb_keys = nb_keys+1 + key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n)) + key_tab(nb_keys)%keystatus = status + key_tab(nb_keys)%keytype = k_typ + key_tab(nb_keys)%keyfromfile = fileorig + key_tab(nb_keys)%keymemstart = k_mempos+1 + IF (l_cmp) THEN + key_tab(nb_keys)%keycompress = size_of_in + key_tab(nb_keys)%keymemlen = 1 + ELSE + key_tab(nb_keys)%keycompress = -1 + key_tab(nb_keys)%keymemlen = size_of_in + ENDIF +!- +! Before writing the actual size lets see if we have the space + IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen & + & > k_memsize) THEN + CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen) + ENDIF +!- + k_beg = key_tab(nb_keys)%keymemstart + k_end = k_beg+key_tab(nb_keys)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen) + i_mempos = k_end + CASE(k_r) + r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen) + r_mempos = k_end + CASE(k_c) + c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen) + c_mempos = k_end + CASE(k_l) + l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen) + l_mempos = k_end + END SELECT +!--------------------- +END SUBROUTINE get_wdb +!- +!=== +!- +SUBROUTINE getin_read +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,SAVE :: allread=0 + INTEGER,SAVE :: current +!--------------------------------------------------------------------- + IF (allread == 0) THEN +!-- Allocate a first set of memory. + CALL getin_alloctxt () + CALL getin_allockeys () + CALL getin_allocmem (k_i,0) + CALL getin_allocmem (k_r,0) + CALL getin_allocmem (k_c,0) + CALL getin_allocmem (k_l,0) +!-- Start with reading the files + nbfiles = 1 + filelist(1) = 'run.def' + current = 1 +!-- + 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,last_key,key_str + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt + INTEGER :: nb_lastkey +!- + INTEGER :: eof,ptn,len_str,i,it,iund,io_err + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + eof = 0 + ptn = 1 + nb_lastkey = 0 +!- + IF (check) THEN + WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) + ENDIF +!- + OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err) + IF (io_err /= 0) THEN + CALL ipslerr (2,'getin_readdef', & + & 'Could not open file '//TRIM(filelist(current)),' ',' ') + RETURN + ENDIF +!- + 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 a vector keyword has the right length + iund = INDEX(key_str,'__') + IF (iund > 0) THEN + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') & + & LEN_TRIM(key_str)-iund-1 + READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), & + & FMT=c_fmt,IOSTAT=io_err) it + IF ( (io_err == 0).AND.(it > 0) ) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + key_str = key_str(1:iund+1)//cnt + ELSE + CALL ipslerr (3,'getin_readdef', & + & 'A very strange key has just been found :', & + & TRIM(key_str),' ') + 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 + CALL ipslerr (3,'getin_readdef', & + & 'We can not have a scalar keyword', & + & 'and a vector content',' ') + ENDIF +!-------- The last keyword needs to be transformed into a vector. + WRITE(UNIT=cnt,FMT=c_i_fmt) 1 + targetlist(nb_lines) = & + & last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt + 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 then the keyword finishes + nb_lastkey = 0 + IF (check) THEN + WRITE(*,*) 'getin_readdef : Have found an emtpy line ' + ENDIF + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + IF (check) THEN + OPEN (UNIT=22,file='run.def.test') + DO i=1,nb_lines + WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i) + ENDDO + CLOSE(UNIT=22) + ENDIF +!--------------------------- +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=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_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 + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + 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 + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + 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 +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 +!- +!-- 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 + CALL ipslerr (3,'getin_decrypt', & + & 'We can not have a compressed field of values', & + & 'in a vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str)) + 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 + CALL ipslerr (2,'getin_decrypt', & + & 'This is a strange behavior','you could report',' ') + ENDIF + WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult) + READ(UNIT=mult,FMT=c_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__00001) +!- + 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),l_n)) + last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + nb_lastkey = 1 + ELSE +!------ We are continuing a vector so the keyword needs +!------ to get the underscores + WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1 + targetlist(nb_lines) = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nb_lastkey+1 + ENDIF +!----- + 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 TARGET__n notation. +!---- +!---- Test if the targer is not already a vector target ! +!- + IF (INDEX(TRIM(key_str),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We have found a mixed vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str),' ') + ENDIF +!- + nbve = nb_lastkey + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) 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),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(TRIM(tmp_str),' ') +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) 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),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nbve +!- + ENDIF +!- + ENDIF +!--------------------------- +END SUBROUTINE getin_decrypt +!- +!=== +!- +SUBROUTINE getin_checkcohe () +!--------------------------------------------------------------------- +!- This subroutine checks for redundancies. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: line,n_k,k +!--------------------------------------------------------------------- + DO line=1,nb_lines-1 +!- + n_k = 0 + DO k=line+1,nb_lines + IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN + n_k = k + EXIT + ENDIF + ENDDO +!--- +!-- IF we have found it we have a problem to solve. +!--- + IF (n_k > 0) THEN + WRITE(*,*) 'COUNT : ',n_k + WRITE(*,*) & + & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) + WRITE(*,*) & + & 'getin_checkcohe : The following values were encoutered :' + WRITE(*,*) & + & ' ',TRIM(targetlist(line)),' == ',fichier(line) + WRITE(*,*) & + & ' ',TRIM(targetlist(k)),' == ',fichier(k) + WRITE(*,*) & + & 'getin_checkcohe : We will keep only the last value' + targetlist(line) = ' ' + 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=unit,FMT='(A)',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 CONTINUE + CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ') +!- +7778 CONTINUE + eof = 1 +!---------------------------- +END SUBROUTINE getin_skipafew +!- +!=== +!- +SUBROUTINE getin_allockeys () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab + CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + IF (keymemsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp,FMT=*) memslabs + ALLOCATE(key_tab(memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + nb_keys = 0 + keymemsize = memslabs + key_tab(:)%keycompress = -1 +!--- + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp,FMT=*) keymemsize + ALLOCATE(tmp_key_tab(keymemsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate tmp_key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs + tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize) + DEALLOCATE(key_tab) + ALLOCATE(key_tab(keymemsize+memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + key_tab(:)%keycompress = -1 + key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize) + DEALLOCATE(tmp_key_tab) + keymemsize = keymemsize+memslabs + ENDIF +!----------------------------- +END SUBROUTINE getin_allockeys +!- +!=== +!- +SUBROUTINE getin_allocmem (type,len_wanted) +!--------------------------------------------------------------------- +!- Allocate the memory of the data base for all 4 types of memory +!- INTEGER / REAL / CHARACTER / LOGICAL +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: type,len_wanted +!- + INTEGER,ALLOCATABLE :: tmp_int(:) + REAL,ALLOCATABLE :: tmp_real(:) + CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) + LOGICAL,ALLOCATABLE :: tmp_logic(:) + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + SELECT CASE (type) + CASE(k_i) + IF (i_memsize == 0) THEN + ALLOCATE(i_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_memsize=memslabs + ELSE + ALLOCATE(tmp_int(i_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_int(1:i_memsize) = i_mem(1:i_memsize) + DEALLOCATE(i_mem) + ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_mem(1:i_memsize) = tmp_int(1:i_memsize) + i_memsize = i_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_int) + ENDIF + CASE(k_r) + IF (r_memsize == 0) THEN + ALLOCATE(r_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_memsize = memslabs + ELSE + ALLOCATE(tmp_real(r_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_real', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_real(1:r_memsize) = r_mem(1:r_memsize) + DEALLOCATE(r_mem) + ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_mem(1:r_memsize) = tmp_real(1:r_memsize) + r_memsize = r_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_real) + ENDIF + CASE(k_c) + IF (c_memsize == 0) THEN + ALLOCATE(c_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_memsize = memslabs + ELSE + ALLOCATE(tmp_char(c_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_char', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_char(1:c_memsize) = c_mem(1:c_memsize) + DEALLOCATE(c_mem) + ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_mem(1:c_memsize) = tmp_char(1:c_memsize) + c_memsize = c_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_char) + ENDIF + CASE(k_l) + IF (l_memsize == 0) THEN + ALLOCATE(l_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_memsize = memslabs + ELSE + ALLOCATE(tmp_logic(l_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_logic', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_logic(1:l_memsize) = l_mem(1:l_memsize) + DEALLOCATE(l_mem) + ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_mem(1:l_memsize) = tmp_logic(1:l_memsize) + l_memsize = l_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_logic) + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ') + END SELECT +!---------------------------- +END SUBROUTINE getin_allocmem +!- +!=== +!- +SUBROUTINE getin_alloctxt () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:) + CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:) + INTEGER,ALLOCATABLE :: tmp_int(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp1,c_tmp2 +!--------------------------------------------------------------------- + IF (i_txtsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtslab + ALLOCATE(fichier(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(targetlist(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(fromfile(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(compline(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + nb_lines = 0 + i_txtsize = i_txtslab + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtsize + WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab + ALLOCATE(tmp_fic(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_fic', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_fic(1:i_txtsize) = fichier(1:i_txtsize) + DEALLOCATE(fichier) + ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fichier(1:i_txtsize) = tmp_fic(1:i_txtsize) + DEALLOCATE(tmp_fic) +!--- + ALLOCATE(tmp_tgl(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_tgl', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize) + DEALLOCATE(targetlist) + ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize) + DEALLOCATE(tmp_tgl) +!--- + ALLOCATE(tmp_int(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_int(1:i_txtsize) = fromfile(1:i_txtsize) + DEALLOCATE(fromfile) + ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fromfile(1:i_txtsize) = tmp_int(1:i_txtsize) +!--- + tmp_int(1:i_txtsize) = compline(1:i_txtsize) + DEALLOCATE(compline) + ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + compline(1:i_txtsize) = tmp_int(1:i_txtsize) + DEALLOCATE(tmp_int) +!--- + i_txtsize = i_txtsize+i_txtslab + ENDIF +!---------------------------- +END SUBROUTINE getin_alloctxt +!- +!=== +!- +SUBROUTINE getin_dump (fileprefix) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(*),OPTIONAL :: fileprefix +!- + CHARACTER(LEN=80) :: usedfileprefix + INTEGER :: ikey,if,iff,iv + CHARACTER(LEN=20) :: c_tmp + CHARACTER(LEN=100) :: tmp_str,used_filename + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (PRESENT(fileprefix)) THEN + usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80)) + ELSE + usedfileprefix = "used" + 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=22,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(22,*) '# ' + WRITE(22,*) '# This file is linked to the following files :' + WRITE(22,*) '# ' + DO iff=2,nbfiles + WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) + ENDDO + WRITE(22,*) '# ' + ENDIF +!--- + DO ikey=1,nb_keys +!----- +!---- Is this key from this file ? + IF (key_tab(ikey)%keyfromfile == if) THEN +!------- +!------ Write some comments + WRITE(22,*) '#' + SELECT CASE (key_tab(ikey)%keystatus) + CASE(1) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' comes from the run.def.' + CASE(2) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' are all defaults.' + CASE(3) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr), & + & ' are a mix of run.def and defaults.' + CASE DEFAULT + WRITE(22,*) '# Dont know from where the value of ', & + & TRIM(key_tab(ikey)%keystr),' comes.' + END SELECT + WRITE(22,*) '#' +!------- +!------ Write the values + SELECT CASE (key_tab(ikey)%keytype) + CASE(k_i) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',i_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',i_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',i_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_r) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',r_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',r_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',r_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_c) + IF (key_tab(ikey)%keymemlen == 1) THEN + tmp_str = c_mem(key_tab(ikey)%keymemstart) + WRITE(22,*) TRIM(key_tab(ikey)%keystr), & + & ' = ',TRIM(tmp_str) + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + tmp_str = c_mem(key_tab(ikey)%keymemstart+iv) + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',TRIM(tmp_str) + ENDDO + ENDIF + CASE(k_l) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (l_mem(key_tab(ikey)%keymemstart)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE ' + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = FALSE ' + ENDIF + ENDDO + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_dump', & + & 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), & + & ' ',' ') + END SELECT + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + ENDDO +!------------------------ +END SUBROUTINE getin_dump +!=== +SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v) +!--------------------------------------------------------------------- +!- Returns the type of the argument (mutually exclusive) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(OUT) :: k_typ + CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp + INTEGER,DIMENSION(:),OPTIONAL :: i_v + REAL,DIMENSION(:),OPTIONAL :: r_v + LOGICAL,DIMENSION(:),OPTIONAL :: l_v + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v +!--------------------------------------------------------------------- + k_typ = 0 + IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) & + & /= 1) THEN + CALL ipslerr (3,'get_qtyp', & + & 'Invalid number of optional arguments','(/= 1)',' ') + ENDIF +!- + IF (PRESENT(i_v)) THEN + k_typ = k_i + c_vtyp = 'INTEGER' + ELSEIF (PRESENT(r_v)) THEN + k_typ = k_r + c_vtyp = 'REAL' + ELSEIF (PRESENT(c_v)) THEN + k_typ = k_c + c_vtyp = 'CHARACTER' + ELSEIF (PRESENT(l_v)) THEN + k_typ = k_l + c_vtyp = 'LOGICAL' + ENDIF +!---------------------- +END SUBROUTINE get_qtyp +!=== +SUBROUTINE get_findkey (i_tab,c_key,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a key in a table +!--------------------------------------------------------------------- +!- INPUT +!- i_tab : 1 -> search in key_tab(1:nb_keys)%keystr +!- 2 -> search in targetlist(1:nb_lines) +!- c_key : Name of the key we are looking for +!- OUTPUT +!- pos : -1 if key not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: i_tab + CHARACTER(LEN=*),INTENT(in) :: c_key + INTEGER,INTENT(out) :: pos +!- + INTEGER :: ikey_max,ikey + CHARACTER(LEN=l_n) :: c_q_key +!--------------------------------------------------------------------- + pos = -1 + IF (i_tab == 1) THEN + ikey_max = nb_keys + ELSEIF (i_tab == 2) THEN + ikey_max = nb_lines + ELSE + ikey_max = 0 + ENDIF + IF ( ikey_max > 0 ) THEN + DO ikey=1,ikey_max + IF (i_tab == 1) THEN + c_q_key = key_tab(ikey)%keystr + ELSE + c_q_key = targetlist(ikey) + ENDIF + IF (TRIM(c_q_key) == TRIM(c_key)) THEN + pos = ikey + EXIT + ENDIF + ENDDO + ENDIF +!------------------------- +END SUBROUTINE get_findkey +!=== +!------------------ +END MODULE ioipsl_getincom Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_stringop.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_stringop.F90 (revision 1186) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_stringop.F90 (revision 1186) @@ -0,0 +1,243 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_stringop +!- +!$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- + 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) +!--------------------------------------------------------------------- +!- Compact blanks +!--------------------------------------------------------------------- + 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 +!--------------------------------------------------------------------- + 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 (str_tab,str,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a string in a table +!--------------------------------------------------------------------- +!- INPUT +!- str_tab : Table of strings +!- str : Target we are looking for +!- OUTPUT +!- pos : -1 if str not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab + CHARACTER(LEN=*),INTENT(in) :: str + INTEGER,INTENT(out) :: pos +!- + INTEGER :: nb_str,i +!--------------------------------------------------------------------- + pos = -1 + nb_str=SIZE(str_tab) + IF ( nb_str > 0 ) THEN + DO i=1,nb_str + IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN + pos = i + EXIT + ENDIF + ENDDO + ENDIF +!---------------------- +END SUBROUTINE find_str +!=== +SUBROUTINE nocomma (str) +!--------------------------------------------------------------------- +!- Replace commas with blanks +!--------------------------------------------------------------------- + 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 Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/write_field.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/write_field.F90 (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/write_field.F90 (revision 1186) @@ -1,4 +1,4 @@ ! -! $Header$ +! $Id$ ! module write_field @@ -72,5 +72,4 @@ subroutine WriteField_gen(name,Field,dimx,dimy,dimz) - USE ioipsl implicit none include 'netcdf.inc' @@ -109,5 +108,4 @@ subroutine CreateNewField(name,dimx,dimy,dimz) - USE ioipsl implicit none include 'netcdf.inc' @@ -229,5 +227,5 @@ write (id,spacing) else - write (id,'') + write (id,'("")') write (id,spacing) endif Index: LMDZ4/branches/LMDZ4-dev/libf/bibio/writedynav.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/bibio/writedynav.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/bibio/writedynav.F (revision 1186) @@ -1,9 +1,11 @@ ! -! $Header$ +! $Id$ ! subroutine writedynav( histid, time, vcov, , ucov,teta,ppk,phi,q,masse,ps,phis) +#ifdef CPP_IOIPSL USE ioipsl +#endif USE infotrac, ONLY : nqtot, ttext implicit none @@ -45,4 +47,5 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C @@ -59,4 +62,6 @@ +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work C Variables locales C @@ -138,4 +143,11 @@ C if (ok_sync) call histsync(histid) + +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"writedynav: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3d/bilan_dyn.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3d/bilan_dyn.F (revision 1185) +++ 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 1185) +++ 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 1185) +++ 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 1185) +++ 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 1185) +++ 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 1185) +++ (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 1185) +++ (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 Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/bilan_dyn_p.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/bilan_dyn_p.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/bilan_dyn_p.F (revision 1186) @@ -1,4 +1,4 @@ ! -! $Header$ +! $Id$ ! SUBROUTINE bilan_dyn_p (ntrac,dt_app,dt_cum, @@ -10,5 +10,7 @@ c vQ..A=Cp T + L * ... +#ifdef CPP_IOIPSL USE IOIPSL +#endif USE parallel USE mod_hallo Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/diagedyn.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/diagedyn.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/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/dyn3dpar/dynredem.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/dynredem.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/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 @@ -457,5 +465,5 @@ dims4(3) = idim_s dims4(4) = idim_tim - + IF(nqtot.GE.1) THEN DO iq=1,nqtot cIM 220306 BEG @@ -468,4 +476,5 @@ ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) ENDDO + ENDIF c dims4(1) = idim_rlonv @@ -631,4 +640,5 @@ END IF + IF(nqtot.GE.1) THEN do iq=1,nqtot @@ -701,4 +711,5 @@ ENDDO + ENDIF c ierr = NF_INQ_VARID(nid, "masse", nvarid) Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/dynredem_p.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/dynredem_p.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/dynredem_p.F (revision 1186) @@ -1,8 +1,10 @@ ! -! $Header$ +! $Id$ ! c SUBROUTINE dynredem0_p(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL USE IOIPSL +#endif USE parallel USE infotrac @@ -57,9 +59,15 @@ if (mpi_rank==0) then - modname='dynredem' - + modname='dynredem0_p' + +#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/dyn3dpar/getparam.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/getparam.F90 (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/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/dyn3dpar/initdynav_p.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/initdynav_p.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/initdynav_p.F (revision 1186) @@ -1,10 +1,11 @@ ! -! $Header$ +! $Id$ ! -c -c subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt,fileid) +#ifdef CPP_IOIPSL +! This routine needs IOIPSL USE IOIPSL +#endif use parallel use Write_field @@ -50,4 +51,5 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C Arguments @@ -57,8 +59,10 @@ real tstep, t_ops, t_wrt integer fileid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C integer thoriid, zvertiid - -C Variables locales -C integer tau0 real zjulian @@ -193,4 +197,8 @@ C call histend(fileid) +#else + write(lunout,*)'initdynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/initfluxsto_p.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/initfluxsto_p.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/initfluxsto_p.F (revision 1186) @@ -1,4 +1,4 @@ ! -! $Header$ +! $Id$ ! subroutine initfluxsto_p @@ -6,5 +6,8 @@ . fileid,filevid,filedid) +#ifdef CPP_IOIPSL +! This routine needs IOIPSL USE IOIPSL +#endif use parallel use Write_field @@ -50,16 +53,17 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C Arguments C character*(*) infile - integer*4 itau real tstep, t_ops, t_wrt integer fileid, filevid,filedid - integer ndex(1) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C real nivd(1) - -C Variables locales -C integer tau0 real zjulian @@ -285,4 +289,8 @@ endif +#else + write(lunout,*)'initfluxsto_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/inithist_p.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/inithist_p.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/inithist_p.F (revision 1186) @@ -1,9 +1,12 @@ ! -! $Header$ +! $Id$ ! subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt, . fileid,filevid) +#ifdef CPP_IOIPSL +! This routine needs IOIPSL USE IOIPSL +#endif use parallel use Write_field @@ -50,4 +53,5 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C Arguments @@ -58,4 +62,6 @@ integer fileid, filevid +#ifdef CPP_IOIPSL +! This routine needs IOIPSL C Variables locales C @@ -244,4 +250,8 @@ call histend(fileid) call histend(filevid) +#else + write(lunout,*)'inithist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/ioipsl_getincom.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/ioipsl_getincom.F90 (revision 1185) +++ (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/dyn3dpar/ioipsl_stringop.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/ioipsl_stringop.F90 (revision 1185) +++ (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 Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/mod_const_para.F90 =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/mod_const_para.F90 (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/mod_const_para.F90 (revision 1186) @@ -1,2 +1,5 @@ +! +! $Id$ +! MODULE mod_const_mpi @@ -8,5 +11,10 @@ SUBROUTINE Init_const_mpi +#ifdef CPP_IOIPSL USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif IMPLICIT NONE Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writedynav_p.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writedynav_p.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writedynav_p.F (revision 1186) @@ -1,9 +1,12 @@ ! -! $Header$ +! $Id$ ! subroutine writedynav_p( histid, time, vcov, , ucov,teta,ppk,phi,q,masse,ps,phis) +#ifdef CPP_IOIPSL +! This routine needs IOIPSL USE ioipsl +#endif USE parallel USE misc_mod @@ -47,4 +50,5 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C @@ -61,4 +65,6 @@ +#ifdef CPP_IOIPSL +! This routine needs IOIPSL C Variables locales C @@ -156,4 +162,8 @@ C if (ok_sync) call histsync(histid) +#else + write(lunout,*)'writedynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL return end Index: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writehist_p.F =================================================================== --- LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writehist_p.F (revision 1185) +++ LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writehist_p.F (revision 1186) @@ -1,9 +1,12 @@ ! -! $Header$ +! $Id$ ! subroutine writehist_p( histid, histvid, time, vcov, , ucov,teta,phi,q,masse,ps,phis) +#ifdef CPP_IOIPSL +! This routine needs IOIPSL USE ioipsl +#endif USE parallel USE misc_mod @@ -48,4 +51,5 @@ #include "description.h" #include "serre.h" +#include "iniprint.h" C @@ -61,5 +65,6 @@ integer time - +#ifdef CPP_IOIPSL +! This routine needs IOIPSL C Variables locales C @@ -144,4 +149,8 @@ call histsync(histvid) endif +#else + write(lunout,*)'writehist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL return end