!$Header: /home/ioipsl/CVSROOT/IOIPSL/src/getincom.f90,v 2.1 2006/04/05 16:18:43 adm Exp $ !- MODULE getincom !--------------------------------------------------------------------- USE 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=500 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,SAVE :: 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,SAVE :: 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,SAVE :: 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,SAVE :: 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 getincom