ns5001k-admin/Nemo-NAA10km_nemo_4.2.2
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Nemo-NAA10km_nemo_4.2.2/tools/REBUILD/BLD/ppsrc/nemo/getincom.f90
Robinson Hordoir 4fa5daa6c3 First commit of Nemo-NAA10km_nemo_4.2.2
2025-09-05 09:42:21 +02:00

2020 lines
60 KiB
Fortran
Raw Blame History

MODULE getincom
!-
!$Id: getincom.f90 2281 2010-10-15 14:21:13Z smasson $
!-
! This software is governed by the CeCILL license
! See IOIPSL/IOIPSL_License_CeCILL.txt
!---------------------------------------------------------------------
USE errioipsl, ONLY : ipslerr
USE stringop, &
& ONLY : nocomma,cmpblank,strlowercase
!-
IMPLICIT NONE
!-
PRIVATE
PUBLIC :: getin_name, getin, getin_dump
!-
!!--------------------------------------------------------------------
!! The "getin_name" routine allows the user to change the name
!! of the definition file in which the data will be read.
!! ("run.def" by default)
!!
!! SUBROUTINE getin_name (file_name)
!!
!! OPTIONAL INPUT argument
!!
!! (C) file_name : the name of the file
!! in which the data will be read
!!--------------------------------------------------------------------
!-
!-
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 definition 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 definition 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,SAVE :: allread=0
CHARACTER(LEN=100),SAVE :: def_file = 'run.def'
!-
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 the file defined by 'def_file'
! 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
!-
!=== DEFINITION FILE NAME INTERFACE
!-
SUBROUTINE getin_name (cname)
!---------------------------------------------------------------------
IMPLICIT NONE
!-
CHARACTER(LEN=*) :: cname
!---------------------------------------------------------------------
IF (allread == 0) THEN
def_file = ADJUSTL(cname)
ELSE
CALL ipslerr (3,'getin_name', &
& 'The name of the database file (any_name.def)', &
& 'must be changed *before* any attempt','to read the database.')
ENDIF
!------------------------
END SUBROUTINE getin_name
!-
!=== 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 :: 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) = TRIM(def_file)
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=TRIM(def_file)//'.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
!-
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 ',TRIM(def_file)
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 ',TRIM(def_file),' 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 getincom
Reference in New Issue View Git Blame Copy Permalink