/[lmdze]/trunk/libf/IOIPSL/getincom.f90
ViewVC logotype

Diff of /trunk/libf/IOIPSL/getincom.f90

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 32 by guez, Tue Apr 6 17:52:58 2010 UTC revision 51 by guez, Tue Sep 20 09:14:34 2011 UTC
# Line 1  Line 1 
1  MODULE getincom  MODULE getincom
2    
3    ! From getincom.f90,v 2.0 2004/04/05 14:47:48    ! From getincom.f90, version 2.0 2004/04/05 14:47:48
4    
   USE nocomma_m, ONLY : nocomma  
   use cmpblank_m, only: cmpblank  
   use strlowercase_m, only: strlowercase  
5    use gensig_m, only: gensig    use gensig_m, only: gensig
6    use find_sig_m, only: find_sig    use find_sig_m, only: find_sig
7      use getincom2, only: nb_keys, keysig, keystr, getfill, getdbwl, getdbrl, &
8           getfilc, getdbwc, getdbrc, getfili, getdbwi, getdbri, getfilr, &
9           getdbwr, getdbrr
10    
11    IMPLICIT NONE    IMPLICIT NONE
12    
13    PRIVATE    PRIVATE
14    PUBLIC :: getin    PUBLIC getin
15    
16    INTERFACE getin    INTERFACE getin
17       MODULE PROCEDURE getinrs, getinr1d, getinr2d, &       MODULE PROCEDURE getinrs, getinr1d, getinr2d, getinis, getini1d, &
18            &                   getinis, getini1d, getini2d, &            getini2d, getincs, getinc1d, getinc2d, getinls, getinl1d, getinl2d
           &                   getincs, getinc1d, getinc2d, &  
           &                   getinls, getinl1d, getinl2d  
19    END INTERFACE    END INTERFACE
20    
   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  
   
21  CONTAINS  CONTAINS
22    
23    !=== REAL INTERFACES    SUBROUTINE getinrs(MY_TARGET, ret_val)
24    
25        ! Get a real scalar. We first check whether we find it in the
26        ! database and if not we get it from "run.def". "getinr1d" and
27        ! "getinr2d" are written on the same pattern.
28    
29        CHARACTER(LEN=*) MY_TARGET
30        REAL ret_val
31    
32        ! Local:
33        REAL, DIMENSION(1):: tmp_ret_val
34        INTEGER:: target_sig, pos, status = 0, fileorig
35    
36        !--------------------------------------------------------------------
37    
   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  
     !---------------------------------------------------------------------  
     
     CHARACTER(LEN=*) :: TARGET  
     REAL :: ret_val  
     
     REAL,DIMENSION(1) :: tmp_ret_val  
     INTEGER :: target_sig, pos, status=0, fileorig  
     !---------------------------------------------------------------------  
     
38      ! Compute the signature of the target      ! Compute the signature of the target
39          CALL gensig(MY_TARGET, target_sig)
40      CALL gensig (TARGET,target_sig)  
41          ! Do we have this my_target in our database ?
     ! Do we have this target in our database ?  
42    
     ! Modification by Lionel GUEZ, April 4th, 2007  
43      ! "find_sig" should not be called if "keystr" and "keysig" are not      ! "find_sig" should not be called if "keystr" and "keysig" are not
44      ! allocated.      ! allocated.
45      ! Avoid this problem with a test on "nb_keys":      ! Avoid this problem with a test on "nb_keys":
46      if (nb_keys > 0) then      if (nb_keys > 0) then
47         CALL find_sig(nb_keys,keystr,target,keysig,target_sig,pos)         CALL find_sig(nb_keys, keystr, my_target, keysig, target_sig, pos)
48      else      else
49         pos = -1         pos = -1
50      end if      end if
51      
52      tmp_ret_val(1) = ret_val      tmp_ret_val(1) = ret_val
53      
54      IF (pos < 0) THEN      IF (pos < 0) THEN
55         !-- Get the information out of the file         ! Get the information out of the file
56         CALL getfilr (TARGET,status,fileorig,tmp_ret_val)         CALL getfilr(MY_TARGET, status, fileorig, tmp_ret_val)
57         !-- Put the data into the database         ! Put the data into the database
58         CALL getdbwr (TARGET,target_sig,status,fileorig,1,tmp_ret_val)         CALL getdbwr(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val)
59      ELSE      ELSE
60         !-- Get the value out of the database         ! Get the value out of the database
61         CALL getdbrr (pos,1,TARGET,tmp_ret_val)         CALL getdbrr (pos, 1, MY_TARGET, tmp_ret_val)
62      ENDIF      ENDIF
63      ret_val = tmp_ret_val(1)      ret_val = tmp_ret_val(1)
64      !---------------------  
65    END SUBROUTINE getinrs    END SUBROUTINE getinrs
66    
67    !****************************    !****************************
68    
69    SUBROUTINE getinr1d (TARGET,ret_val)    SUBROUTINE getinr1d(MY_TARGET, ret_val)
70      !---------------------------------------------------------------------  
71      !- See getinrs for details. It is the same thing but for a vector      ! See getinrs for details. It is the same thing but for a vector
72      !---------------------------------------------------------------------  
73      
74      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
75      REAL,DIMENSION(:) :: ret_val      REAL, DIMENSION(:) :: ret_val
76      
77      REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      REAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
78      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
79      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
80      !---------------------------------------------------------------------  
81      
82      ! Compute the signature of the target      ! Compute the signature of the target
83      
84      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
85      
86      ! Do we have this target in our database ?      ! Do we have this target in our database ?
87      
88      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
89      
90      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
91      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
92         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
# Line 156  CONTAINS Line 96  CONTAINS
96         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
97      ENDIF      ENDIF
98      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
99      
100      IF (pos < 0) THEN      IF (pos < 0) THEN
101         !-- Ge the information out of the file         ! Ge the information out of the file
102         CALL getfilr (TARGET,status,fileorig,tmp_ret_val)         CALL getfilr(MY_TARGET, status, fileorig, tmp_ret_val)
103         !-- Put the data into the database         ! Put the data into the database
104         CALL getdbwr &         CALL getdbwr &
105              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
106      ELSE      ELSE
107         !-- Get the value out of the database         ! Get the value out of the database
108         CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbrr (pos, size_of_in, MY_TARGET, tmp_ret_val)
109      ENDIF      ENDIF
110      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
111      !----------------------  
112    END SUBROUTINE getinr1d    END SUBROUTINE getinr1d
113    
114    !****************************    !****************************
115    
116    SUBROUTINE getinr2d (TARGET,ret_val)    SUBROUTINE getinr2d(MY_TARGET, ret_val)
117      !---------------------------------------------------------------------  
118      !- See getinrs for details. It is the same thing but for a matrix      ! See getinrs for details. It is the same thing but for a matrix
119      !---------------------------------------------------------------------  
120      
121      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
122      REAL,DIMENSION(:,:) :: ret_val      REAL, DIMENSION(:, :) :: ret_val
123      
124      REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      REAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
125      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
126      INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig      INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig
127      INTEGER :: jl, jj, ji      INTEGER :: jl, jj, ji
128      !---------------------------------------------------------------------  
129      
130      ! Compute the signature of the target      ! Compute the signature of the target
131      
132      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
133      
134      ! Do we have this target in our database ?      ! Do we have this target in our database ?
135      
136      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
137      
138      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
139      size_1 = SIZE(ret_val,1)      size_1 = SIZE(ret_val, 1)
140      size_2 = SIZE(ret_val,2)      size_2 = SIZE(ret_val, 2)
141      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
142         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
143      ELSE IF (size_of_in > tmp_ret_size) THEN      ELSE IF (size_of_in > tmp_ret_size) THEN
# Line 205  CONTAINS Line 145  CONTAINS
145         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
146         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
147      ENDIF      ENDIF
148      
149      jl=0      jl=0
150      DO jj=1,size_2      DO jj=1, size_2
151         DO ji=1,size_1         DO ji=1, size_1
152            jl=jl+1            jl=jl+1
153            tmp_ret_val(jl) = ret_val(ji,jj)            tmp_ret_val(jl) = ret_val(ji, jj)
154         ENDDO         ENDDO
155      ENDDO      ENDDO
156      
157      IF (pos < 0) THEN      IF (pos < 0) THEN
158         !-- Ge the information out of the file         ! Ge the information out of the file
159         CALL getfilr (TARGET,status,fileorig,tmp_ret_val)         CALL getfilr(MY_TARGET, status, fileorig, tmp_ret_val)
160         !-- Put the data into the database         ! Put the data into the database
161         CALL getdbwr &         CALL getdbwr &
162              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
163      ELSE      ELSE
164         !-- Get the value out of the database         ! Get the value out of the database
165         CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbrr (pos, size_of_in, MY_TARGET, tmp_ret_val)
166      ENDIF      ENDIF
167      
168      jl=0      jl=0
169      DO jj=1,size_2      DO jj=1, size_2
170         DO ji=1,size_1         DO ji=1, size_1
171            jl=jl+1            jl=jl+1
172            ret_val(ji,jj) = tmp_ret_val(jl)            ret_val(ji, jj) = tmp_ret_val(jl)
173         ENDDO         ENDDO
174      ENDDO      ENDDO
175      !----------------------  
176    END SUBROUTINE getinr2d    END SUBROUTINE getinr2d
177    
178    !****************************    !****************************
179    
180    SUBROUTINE getfilr (TARGET,status,fileorig,ret_val)    SUBROUTINE getinis(MY_TARGET, ret_val)
181      !---------------------------------------------------------------------  
182      !- Subroutine that will extract from the file the values      ! Get a interer scalar. We first check if we find it
183      !- attributed to the keyword target      ! in the database and if not we get it from the run.def
184      
185      !- REALS      ! getini1d and getini2d are written on the same pattern
     !- -----  
     
     !- 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  
     !---------------------------------------------------------------------  
     
     CHARACTER(LEN=*) :: TARGET  
     INTEGER :: status, fileorig  
     REAL,DIMENSION(:) :: ret_val  
     
     INTEGER :: nb_to_ret  
     INTEGER :: it, pos, len_str, epos, ppos, int_tmp, status_cnt  
     CHARACTER(LEN=3)  :: cnt, tl, dl  
     CHARACTER(LEN=10) :: fmt  
     CHARACTER(LEN=30) :: full_target  
     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp  
     INTEGER :: full_target_sig  
     REAL :: compvalue  
     
     INTEGER,SAVE :: max_len = 0  
     LOGICAL,SAVE,ALLOCATABLE :: found(:)  
     LOGICAL :: def_beha  
     LOGICAL :: compressed = .FALSE.  
     !---------------------------------------------------------------------  
     nb_to_ret = SIZE(ret_val)  
     CALL getin_read  
     
     ! Get the variables and memory we need  
     
     IF (max_len == 0) THEN  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     IF (max_len < nb_to_ret) THEN  
        DEALLOCATE(found)  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     found(:) = .FALSE.  
     
     ! See what we find in the files read  
     
     DO it=1,nb_to_ret  
        !---  
       
        !-- First try the target as it is  
        !---  
        full_target = TARGET(1:len_TRIM(target))  
        CALL gensig (full_target,full_target_sig)  
        CALL find_sig (nb_lines,targetlist,full_target, &  
             &                 targetsiglist,full_target_sig,pos)  
        !---  
        !-- Another try  
        !---  
        IF (pos < 0) THEN  
           WRITE(cnt,'(I3.3)') it  
           full_target = TARGET(1:len_TRIM(target))//'__'//cnt  
           CALL gensig (full_target,full_target_sig)  
           CALL find_sig (nb_lines,targetlist,full_target, &  
                &                   targetsiglist,full_target_sig,pos)  
        ENDIF  
        !---  
        !-- A priori we dont know from which file the target could come.  
        !-- Thus by default we attribute it to the first file :  
        !---  
        fileorig = 1  
        !--  
        IF (pos > 0) THEN  
           !----  
           found(it) = .TRUE.  
           fileorig = fromfile(pos)  
           !-----  
           !---- DECODE  
           !-----  
           str_READ = TRIM(ADJUSTL(fichier(pos)))  
           str_READ_lower = str_READ  
           CALL strlowercase (str_READ_lower)  
           !----  
           IF (    (     (INDEX(str_READ_lower,'def') == 1)     &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &  
                &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN  
              def_beha = .TRUE.  
           ELSE  
              def_beha = .FALSE.  
              len_str = LEN_TRIM(str_READ)  
              epos = INDEX(str_READ,'e')  
              ppos = INDEX(str_READ,'.')  
              !------  
              IF (epos > 0) THEN  
                 WRITE(tl,'(I3.3)') len_str  
                 WRITE(dl,'(I3.3)') epos-ppos-1  
                 fmt='(e'//tl//'.'//dl//')'  
                 READ(str_READ,fmt) ret_val(it)  
              ELSE IF (ppos > 0) THEN  
                 WRITE(tl,'(I3.3)') len_str  
                 WRITE(dl,'(I3.3)') len_str-ppos  
                 fmt='(f'//tl//'.'//dl//')'  
                 READ(str_READ,fmt) ret_val(it)  
              ELSE  
                 WRITE(tl,'(I3.3)') len_str  
                 fmt = '(I'//tl//')'  
                 READ(str_READ,fmt) int_tmp  
                 ret_val(it) = REAL(int_tmp)  
              ENDIF  
           ENDIF  
           !----  
           targetsiglist(pos) = -1  
           !-----  
           !---- Is this the value of a compressed field ?  
           !-----  
           IF (compline(pos) > 0) THEN  
              IF (compline(pos) == nb_to_ret) THEN  
                 compressed = .TRUE.  
                 compvalue = ret_val(it)  
              ELSE  
                 WRITE(*,*) 'WARNING from getfilr'  
                 WRITE(*,*) 'For key ',TRIM(TARGET), &  
                      & ' we have a compressed field but which does not have the right size.'  
                 WRITE(*,*) 'We will try to fix that '  
                 compressed = .TRUE.  
                 compvalue = ret_val(it)  
              ENDIF  
           ENDIF  
        ELSE  
           found(it) = .FALSE.  
        ENDIF  
     ENDDO  
     !--  
     ! If this is a compressed field then we will uncompress it  
     !--  
     IF (compressed) THEN  
        DO it=1,nb_to_ret  
           IF (.NOT. found(it)) THEN  
              ret_val(it) = compvalue  
              found(it) = .TRUE.  
           ENDIF  
        ENDDO  
     ENDIF  
     
     ! Now we get the status for what we found  
     
     IF (def_beha) THEN  
        status = 2  
        WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)  
     ELSE  
        status_cnt = 0  
        DO it=1,nb_to_ret  
           IF (.NOT. found(it)) THEN  
              status_cnt = status_cnt+1  
              IF (nb_to_ret > 1) THEN  
                 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it  
              ELSE  
                 str_tmp = TRIM(TARGET)  
              ENDIF  
              WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)  
           ENDIF  
        ENDDO  
        !---  
        IF (status_cnt == 0) THEN  
           status = 1  
        ELSE IF (status_cnt == nb_to_ret) THEN  
           status = 2  
        ELSE  
           status = 3  
        ENDIF  
     ENDIF  
     !---------------------  
   END SUBROUTINE getfilr  
186    
   !=== INTEGER INTERFACES  
187    
188    SUBROUTINE getinis (TARGET,ret_val)      CHARACTER(LEN=*) :: MY_TARGET
     !---------------------------------------------------------------------  
     !- 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  
     !---------------------------------------------------------------------  
     
     CHARACTER(LEN=*) :: TARGET  
189      INTEGER :: ret_val      INTEGER :: ret_val
190      
191      INTEGER,DIMENSION(1) :: tmp_ret_val      INTEGER, DIMENSION(1) :: tmp_ret_val
192      INTEGER :: target_sig, pos, status=0, fileorig      INTEGER :: target_sig, pos, status=0, fileorig
193      !---------------------------------------------------------------------  
194      
195      ! Compute the signature of the target      ! Compute the signature of the target
196      
197      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
198      
199      ! Do we have this target in our database ?      ! Do we have this target in our database ?
200      
201      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
202      
203      tmp_ret_val(1) = ret_val      tmp_ret_val(1) = ret_val
204      
205      IF (pos < 0) THEN      IF (pos < 0) THEN
206         !-- Ge the information out of the file         ! Ge the information out of the file
207         CALL getfili (TARGET,status,fileorig,tmp_ret_val)         CALL getfili(MY_TARGET, status, fileorig, tmp_ret_val)
208         !-- Put the data into the database         ! Put the data into the database
209         CALL getdbwi (TARGET,target_sig,status,fileorig,1,tmp_ret_val)         CALL getdbwi(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val)
210      ELSE      ELSE
211         !-- Get the value out of the database         ! Get the value out of the database
212         CALL getdbri (pos,1,TARGET,tmp_ret_val)         CALL getdbri (pos, 1, MY_TARGET, tmp_ret_val)
213      ENDIF      ENDIF
214      ret_val = tmp_ret_val(1)      ret_val = tmp_ret_val(1)
215      !---------------------  
216    END SUBROUTINE getinis    END SUBROUTINE getinis
217    
218    !****************************    !****************************
219    
220    SUBROUTINE getini1d (TARGET,ret_val)    SUBROUTINE getini1d(MY_TARGET, ret_val)
221      !---------------------------------------------------------------------  
222      !- See getinis for details. It is the same thing but for a vector      ! See getinis for details. It is the same thing but for a vector
223      !---------------------------------------------------------------------  
224      
225      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
226      INTEGER,DIMENSION(:) :: ret_val      INTEGER, DIMENSION(:) :: ret_val
227      
228      INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
229      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
230      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
231      !---------------------------------------------------------------------  
232      
233      ! Compute the signature of the target      ! Compute the signature of the target
234      
235      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
236      
237      ! Do we have this target in our database ?      ! Do we have this target in our database ?
238      
239      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
240      
241      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
242      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
243         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
# Line 488  CONTAINS Line 247  CONTAINS
247         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
248      ENDIF      ENDIF
249      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
250      
251      IF (pos < 0) THEN      IF (pos < 0) THEN
252         !-- Ge the information out of the file         ! Ge the information out of the file
253         CALL getfili (TARGET,status,fileorig,tmp_ret_val)         CALL getfili(MY_TARGET, status, fileorig, tmp_ret_val)
254         !-- Put the data into the database         ! Put the data into the database
255         CALL getdbwi &         CALL getdbwi &
256              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
257      ELSE      ELSE
258         !-- Get the value out of the database         ! Get the value out of the database
259         CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbri (pos, size_of_in, MY_TARGET, tmp_ret_val)
260      ENDIF      ENDIF
261      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
262      !----------------------  
263    END SUBROUTINE getini1d    END SUBROUTINE getini1d
264    
265    !****************************    !****************************
266    
267    SUBROUTINE getini2d (TARGET,ret_val)    SUBROUTINE getini2d(MY_TARGET, ret_val)
268      !---------------------------------------------------------------------  
269      !- See getinis for details. It is the same thing but for a matrix      ! See getinis for details. It is the same thing but for a matrix
270      !---------------------------------------------------------------------  
271      
272      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
273      INTEGER,DIMENSION(:,:) :: ret_val      INTEGER, DIMENSION(:, :) :: ret_val
274      
275      INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
276      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
277      INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig      INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig
278      INTEGER :: jl, jj, ji      INTEGER :: jl, jj, ji
279      !---------------------------------------------------------------------  
280      
281      ! Compute the signature of the target      ! Compute the signature of the target
282      
283      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
284      
285      ! Do we have this target in our database ?      ! Do we have this target in our database ?
286      
287      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
288      
289      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
290      size_1 = SIZE(ret_val,1)      size_1 = SIZE(ret_val, 1)
291      size_2 = SIZE(ret_val,2)      size_2 = SIZE(ret_val, 2)
292      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
293         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
294      ELSE IF (size_of_in > tmp_ret_size) THEN      ELSE IF (size_of_in > tmp_ret_size) THEN
# Line 537  CONTAINS Line 296  CONTAINS
296         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
297         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
298      ENDIF      ENDIF
299      
300      jl=0      jl=0
301      DO jj=1,size_2      DO jj=1, size_2
302         DO ji=1,size_1         DO ji=1, size_1
303            jl=jl+1            jl=jl+1
304            tmp_ret_val(jl) = ret_val(ji,jj)            tmp_ret_val(jl) = ret_val(ji, jj)
305         ENDDO         ENDDO
306      ENDDO      ENDDO
307      
308      IF (pos < 0) THEN      IF (pos < 0) THEN
309         !-- Ge the information out of the file         ! Ge the information out of the file
310         CALL getfili (TARGET,status,fileorig,tmp_ret_val)         CALL getfili(MY_TARGET, status, fileorig, tmp_ret_val)
311         !-- Put the data into the database         ! Put the data into the database
312         CALL getdbwi &         CALL getdbwi &
313              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
314      ELSE      ELSE
315         !-- Get the value out of the database         ! Get the value out of the database
316         CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbri (pos, size_of_in, MY_TARGET, tmp_ret_val)
317      ENDIF      ENDIF
318      
319      jl=0      jl=0
320      DO jj=1,size_2      DO jj=1, size_2
321         DO ji=1,size_1         DO ji=1, size_1
322            jl=jl+1            jl=jl+1
323            ret_val(ji,jj) = tmp_ret_val(jl)            ret_val(ji, jj) = tmp_ret_val(jl)
324         ENDDO         ENDDO
325      ENDDO      ENDDO
326      !----------------------  
327    END SUBROUTINE getini2d    END SUBROUTINE getini2d
328    
329    !****************************    !****************************
330    
   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  
     !---------------------------------------------------------------------  
     
     CHARACTER(LEN=*) :: TARGET  
     INTEGER :: status, fileorig  
     INTEGER :: ret_val(:)  
     
     INTEGER :: nb_to_ret  
     INTEGER :: it, pos, len_str, status_cnt  
     CHARACTER(LEN=3)  :: cnt, chlen  
     CHARACTER(LEN=10) ::  fmt  
     CHARACTER(LEN=30) :: full_target  
     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp  
     INTEGER :: full_target_sig  
     INTEGER :: compvalue  
     
     INTEGER,SAVE :: max_len = 0  
     LOGICAL,SAVE,ALLOCATABLE :: found(:)  
     LOGICAL :: def_beha  
     LOGICAL :: compressed = .FALSE.  
     !---------------------------------------------------------------------  
     nb_to_ret = SIZE(ret_val)  
     CALL getin_read  
     
     ! Get the variables and memory we need  
     
     IF (max_len == 0) THEN  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     IF (max_len < nb_to_ret) THEN  
        DEALLOCATE(found)  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     found(:) = .FALSE.  
     
     ! See what we find in the files read  
     
     DO it=1,nb_to_ret  
        !---  
        !-- First try the target as it is  
        !---  
        full_target = TARGET(1:len_TRIM(target))  
        CALL gensig (full_target,full_target_sig)  
        CALL find_sig (nb_lines,targetlist,full_target, &  
             &                 targetsiglist,full_target_sig,pos)  
        !---  
        !-- Another try  
        !---  
        IF (pos < 0) THEN  
           WRITE(cnt,'(I3.3)') it  
           full_target = TARGET(1:len_TRIM(target))//'__'//cnt  
           CALL gensig (full_target,full_target_sig)  
           CALL find_sig (nb_lines,targetlist,full_target, &  
                &                   targetsiglist,full_target_sig,pos)  
        ENDIF  
        !---  
        !-- A priori we dont know from which file the target could come.  
        !-- Thus by default we attribute it to the first file :  
        !---  
        fileorig = 1  
       
        IF (pos > 0) THEN  
           !-----  
           found(it) = .TRUE.  
           fileorig = fromfile(pos)  
           !-----  
           !---- DECODE  
           !----  
           str_READ = TRIM(ADJUSTL(fichier(pos)))  
           str_READ_lower = str_READ  
           CALL strlowercase (str_READ_lower)  
           !-----  
           IF (    (     (INDEX(str_READ_lower,'def') == 1)     &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &  
                &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN  
              def_beha = .TRUE.  
           ELSE  
              def_beha = .FALSE.  
              len_str = LEN_TRIM(str_READ)  
              WRITE(chlen,'(I3.3)') len_str  
              fmt = '(I'//chlen//')'  
              READ(str_READ,fmt) ret_val(it)  
           ENDIF  
           !-----  
           targetsiglist(pos) = -1  
           !-----  
           !---- Is this the value of a compressed field ?  
           !-----  
           IF (compline(pos) > 0) THEN  
              IF (compline(pos) == nb_to_ret) THEN  
                 compressed = .TRUE.  
                 compvalue = ret_val(it)  
              ELSE  
                 WRITE(*,*) 'WARNING from getfilr'  
                 WRITE(*,*) 'For key ',TRIM(TARGET), &  
                      & ' we have a compressed field but which does not have the right size.'  
                 WRITE(*,*) 'We will try to fix that '  
                 compressed = .TRUE.  
                 compvalue = ret_val(it)  
              ENDIF  
           ENDIF  
        ELSE  
           found(it) = .FALSE.  
        ENDIF  
     ENDDO  
     
     ! If this is a compressed field then we will uncompress it  
     
     IF (compressed) THEN  
        DO it=1,nb_to_ret  
           IF (.NOT. found(it)) THEN  
              ret_val(it) = compvalue  
              found(it) = .TRUE.  
           ENDIF  
        ENDDO  
     ENDIF  
     
     ! Now we get the status for what we found  
     
     IF (def_beha) THEN  
        status = 2  
        WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)  
     ELSE  
        status_cnt = 0  
        DO it=1,nb_to_ret  
           IF (.NOT. found(it)) THEN  
              status_cnt = status_cnt+1  
              IF (nb_to_ret > 1) THEN  
                 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it  
              ELSE  
                 str_tmp = TRIM(TARGET)  
              ENDIF  
              WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)  
           ENDIF  
        ENDDO  
        !---  
        IF (status_cnt == 0) THEN  
           status = 1  
        ELSE IF (status_cnt == nb_to_ret) THEN  
           status = 2  
        ELSE  
           status = 3  
        ENDIF  
     ENDIF  
     !---------------------  
   END SUBROUTINE getfili  
   
331    !=== CHARACTER INTERFACES    !=== CHARACTER INTERFACES
332    
333    SUBROUTINE getincs (TARGET,ret_val)    SUBROUTINE getincs(MY_TARGET, ret_val)
334      !---------------------------------------------------------------------  
335      !- Get a CHARACTER scalar. We first check if we find it      ! Get a CHARACTER scalar. We first check if we find it
336      !- in the database and if not we get it from the run.def      ! in the database and if not we get it from the run.def
337      
338      !- getinc1d and getinc2d are written on the same pattern      ! getinc1d and getinc2d are written on the same pattern
339      !---------------------------------------------------------------------  
340      
341      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
342      CHARACTER(LEN=*) :: ret_val      CHARACTER(LEN=*) :: ret_val
343      
344      CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val      CHARACTER(LEN=100), DIMENSION(1) :: tmp_ret_val
345      INTEGER :: target_sig, pos, status=0, fileorig      INTEGER :: target_sig, pos, status=0, fileorig
346      !---------------------------------------------------------------------  
347      
348      ! Compute the signature of the target      ! Compute the signature of the target
349      
350      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
351      
352      ! Do we have this target in our database ?      ! Do we have this target in our database ?
353      
354      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
355      
356      tmp_ret_val(1) = ret_val      tmp_ret_val(1) = ret_val
357      
358      IF (pos < 0) THEN      IF (pos < 0) THEN
359         !-- Ge the information out of the file         ! Ge the information out of the file
360         CALL getfilc (TARGET,status,fileorig,tmp_ret_val)         CALL getfilc(MY_TARGET, status, fileorig, tmp_ret_val)
361         !-- Put the data into the database         ! Put the data into the database
362         CALL getdbwc (TARGET,target_sig,status,fileorig,1,tmp_ret_val)         CALL getdbwc(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val)
363      ELSE      ELSE
364         !-- Get the value out of the database         ! Get the value out of the database
365         CALL getdbrc (pos,1,TARGET,tmp_ret_val)         CALL getdbrc (pos, 1, MY_TARGET, tmp_ret_val)
366      ENDIF      ENDIF
367      ret_val = tmp_ret_val(1)      ret_val = tmp_ret_val(1)
368      !---------------------  
369    END SUBROUTINE getincs    END SUBROUTINE getincs
370    
371    !****************************    !****************************
372    
373    SUBROUTINE getinc1d (TARGET,ret_val)    SUBROUTINE getinc1d(MY_TARGET, ret_val)
374      !---------------------------------------------------------------------  
375      !- See getincs for details. It is the same thing but for a vector      ! See getincs for details. It is the same thing but for a vector
376      !---------------------------------------------------------------------  
377      
378      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
379      CHARACTER(LEN=*),DIMENSION(:) :: ret_val      CHARACTER(LEN=*), DIMENSION(:) :: ret_val
380      
381      CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      CHARACTER(LEN=100), DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
382      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
383      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
384      !---------------------------------------------------------------------  
385      
386      ! Compute the signature of the target      ! Compute the signature of the target
387      
388      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
389      
390      ! Do we have this target in our database ?      ! Do we have this target in our database ?
391      
392      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
393      
394      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
395      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
396         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
# Line 803  CONTAINS Line 400  CONTAINS
400         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
401      ENDIF      ENDIF
402      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
403      
404      IF (pos < 0) THEN      IF (pos < 0) THEN
405         !-- Ge the information out of the file         ! Ge the information out of the file
406         CALL getfilc (TARGET,status,fileorig,tmp_ret_val)         CALL getfilc(MY_TARGET, status, fileorig, tmp_ret_val)
407         !-- Put the data into the database         ! Put the data into the database
408         CALL getdbwc &         CALL getdbwc &
409              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
410      ELSE      ELSE
411         !-- Get the value out of the database         ! Get the value out of the database
412         CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbrc (pos, size_of_in, MY_TARGET, tmp_ret_val)
413      ENDIF      ENDIF
414      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
415      !----------------------  
416    END SUBROUTINE getinc1d    END SUBROUTINE getinc1d
417    
418    !****************************    !****************************
419    
420    SUBROUTINE getinc2d (TARGET,ret_val)    SUBROUTINE getinc2d(MY_TARGET, ret_val)
421      !---------------------------------------------------------------------  
422      !- See getincs for details. It is the same thing but for a matrix      ! See getincs for details. It is the same thing but for a matrix
423      !---------------------------------------------------------------------  
424      
425      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
426      CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val      CHARACTER(LEN=*), DIMENSION(:, :) :: ret_val
427      
428      CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      CHARACTER(LEN=100), DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
429      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
430      INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig      INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig
431      INTEGER :: jl,jj,ji      INTEGER :: jl, jj, ji
432      !---------------------------------------------------------------------  
433      
434      ! Compute the signature of the target      ! Compute the signature of the target
435      
436      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
437      
438      ! Do we have this target in our database ?      ! Do we have this target in our database ?
439      
440      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
441      
442      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
443      size_1 = SIZE(ret_val,1)      size_1 = SIZE(ret_val, 1)
444      size_2 = SIZE(ret_val,2)      size_2 = SIZE(ret_val, 2)
445      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
446         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
447      ELSE IF (size_of_in > tmp_ret_size) THEN      ELSE IF (size_of_in > tmp_ret_size) THEN
# Line 852  CONTAINS Line 449  CONTAINS
449         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
450         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
451      ENDIF      ENDIF
452      
453      jl=0      jl=0
454      DO jj=1,size_2      DO jj=1, size_2
455         DO ji=1,size_1         DO ji=1, size_1
456            jl=jl+1            jl=jl+1
457            tmp_ret_val(jl) = ret_val(ji,jj)            tmp_ret_val(jl) = ret_val(ji, jj)
458         ENDDO         ENDDO
459      ENDDO      ENDDO
460      
461      IF (pos < 0) THEN      IF (pos < 0) THEN
462         !-- Ge the information out of the file         ! Ge the information out of the file
463         CALL getfilc (TARGET,status,fileorig,tmp_ret_val)         CALL getfilc(MY_TARGET, status, fileorig, tmp_ret_val)
464         !-- Put the data into the database         ! Put the data into the database
465         CALL getdbwc &         CALL getdbwc &
466              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
467      ELSE      ELSE
468         !-- Get the value out of the database         ! Get the value out of the database
469         CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbrc (pos, size_of_in, MY_TARGET, tmp_ret_val)
470      ENDIF      ENDIF
471      
472      jl=0      jl=0
473      DO jj=1,size_2      DO jj=1, size_2
474         DO ji=1,size_1         DO ji=1, size_1
475            jl=jl+1            jl=jl+1
476            ret_val(ji,jj) = tmp_ret_val(jl)            ret_val(ji, jj) = tmp_ret_val(jl)
477         ENDDO         ENDDO
478      ENDDO      ENDDO
479      !----------------------  
480    END SUBROUTINE getinc2d    END SUBROUTINE getinc2d
481    
482    !****************************    !****************************
483    
   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  
     !---------------------------------------------------------------------  
     
     
     CHARACTER(LEN=*) :: TARGET  
     INTEGER :: status, fileorig  
     CHARACTER(LEN=*),DIMENSION(:) :: ret_val  
     
     INTEGER :: nb_to_ret  
     INTEGER :: it, pos, len_str, status_cnt  
     CHARACTER(LEN=3)  :: cnt  
     CHARACTER(LEN=30) :: full_target  
     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp  
     INTEGER :: full_target_sig  
     
     INTEGER,SAVE :: max_len = 0  
     LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found  
     LOGICAL :: def_beha  
     !---------------------------------------------------------------------  
     nb_to_ret = SIZE(ret_val)  
     CALL getin_read  
     
     ! Get the variables and memory we need  
     
     IF (max_len == 0) THEN  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     IF (max_len < nb_to_ret) THEN  
        DEALLOCATE(found)  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     found(:) = .FALSE.  
     
     ! See what we find in the files read  
     
     DO it=1,nb_to_ret  
        !---  
        !-- First try the target as it is  
        full_target = TARGET(1:len_TRIM(target))  
        CALL gensig (full_target,full_target_sig)  
        CALL find_sig (nb_lines,targetlist,full_target, &  
             &                 targetsiglist,full_target_sig,pos)  
        !---  
        !-- Another try  
        !---  
        IF (pos < 0) THEN  
           WRITE(cnt,'(I3.3)') it  
           full_target = TARGET(1:len_TRIM(target))//'__'//cnt  
           CALL gensig (full_target,full_target_sig)  
           CALL find_sig (nb_lines,targetlist,full_target, &  
                &                   targetsiglist,full_target_sig,pos)  
        ENDIF  
        !---  
        !-- A priori we dont know from which file the target could come.  
        !-- Thus by default we attribute it to the first file :  
        !---  
        fileorig = 1  
        !---  
        IF (pos > 0) THEN  
           !-----  
           found(it) = .TRUE.  
           fileorig = fromfile(pos)  
           !-----  
           !---- DECODE  
           !-----  
           str_READ = TRIM(ADJUSTL(fichier(pos)))  
           str_READ_lower = str_READ  
           CALL strlowercase (str_READ_lower)  
           !-----  
           IF (    (     (INDEX(str_READ_lower,'def') == 1)     &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &  
                &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN  
              def_beha = .TRUE.  
           ELSE  
              def_beha = .FALSE.  
              len_str = LEN_TRIM(str_READ)  
              ret_val(it) = str_READ(1:len_str)  
           ENDIF  
           !-----  
           targetsiglist(pos) = -1  
           !-----  
        ELSE  
           found(it) = .FALSE.  
        ENDIF  
     ENDDO  
     
     ! Now we get the status for what we found  
     
     IF (def_beha) THEN  
        status = 2  
        WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)  
     ELSE  
        status_cnt = 0  
        DO it=1,nb_to_ret  
           IF (.NOT. found(it)) THEN  
              status_cnt = status_cnt+1  
              IF (nb_to_ret > 1) THEN  
                 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it  
              ELSE  
                 str_tmp = TARGET(1:len_TRIM(target))  
              ENDIF  
              WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)  
           ENDIF  
        ENDDO  
       
        IF (status_cnt == 0) THEN  
           status = 1  
        ELSE IF (status_cnt == nb_to_ret) THEN  
           status = 2  
        ELSE  
           status = 3  
        ENDIF  
     ENDIF  
     !---------------------  
   END SUBROUTINE getfilc  
   
484    !=== LOGICAL INTERFACES    !=== LOGICAL INTERFACES
485    
486    SUBROUTINE getinls (TARGET,ret_val)    SUBROUTINE getinls(MY_TARGET, ret_val)
487      !---------------------------------------------------------------------  
488      !- Get a logical scalar. We first check if we find it      ! Get a logical scalar. We first check if we find it
489      !- in the database and if not we get it from the run.def      ! in the database and if not we get it from the run.def
490      
491      !- getinl1d and getinl2d are written on the same pattern      ! getinl1d and getinl2d are written on the same pattern
492      !---------------------------------------------------------------------  
493      
494      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
495      LOGICAL :: ret_val      LOGICAL :: ret_val
496      
497      LOGICAL,DIMENSION(1) :: tmp_ret_val      LOGICAL, DIMENSION(1) :: tmp_ret_val
498      INTEGER :: target_sig, pos, status=0, fileorig      INTEGER :: target_sig, pos, status=0, fileorig
499      !---------------------------------------------------------------------  
500      
501      ! Compute the signature of the target      ! Compute the signature of the target
502      
503      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
504      
505      ! Do we have this target in our database ?      ! Do we have this target in our database ?
506      
507      if (nb_keys > 0) then      if (nb_keys > 0) then
508         CALL find_sig(nb_keys,keystr,target,keysig,target_sig,pos)         CALL find_sig(nb_keys, keystr, my_target, keysig, target_sig, pos)
509      else      else
510         pos = -1         pos = -1
511      end if      end if
512      
513      tmp_ret_val(1) = ret_val      tmp_ret_val(1) = ret_val
514      
515      IF (pos < 0) THEN      IF (pos < 0) THEN
516         !-- Ge the information out of the file         ! Ge the information out of the file
517         CALL getfill (TARGET,status,fileorig,tmp_ret_val)         CALL getfill(MY_TARGET, status, fileorig, tmp_ret_val)
518         !-- Put the data into the database         ! Put the data into the database
519         CALL getdbwl (TARGET,target_sig,status,fileorig,1,tmp_ret_val)         CALL getdbwl(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val)
520      ELSE      ELSE
521         !-- Get the value out of the database         ! Get the value out of the database
522         CALL getdbrl (pos,1,TARGET,tmp_ret_val)         CALL getdbrl (pos, 1, MY_TARGET, tmp_ret_val)
523      ENDIF      ENDIF
524      ret_val = tmp_ret_val(1)      ret_val = tmp_ret_val(1)
525      !---------------------  
526    END SUBROUTINE getinls    END SUBROUTINE getinls
527    
528    !****************************    !****************************
529    
530    SUBROUTINE getinl1d (TARGET,ret_val)    SUBROUTINE getinl1d(MY_TARGET, ret_val)
531      !---------------------------------------------------------------------  
532      !- See getinls for details. It is the same thing but for a vector      ! See getinls for details. It is the same thing but for a vector
533      !---------------------------------------------------------------------  
534      
535      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
536      LOGICAL,DIMENSION(:) :: ret_val      LOGICAL, DIMENSION(:) :: ret_val
537      
538      LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      LOGICAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
539      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
540      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig      INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
541      !---------------------------------------------------------------------  
542      
543      ! Compute the signature of the target      ! Compute the signature of the target
544      
545      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
546      
547      ! Do we have this target in our database ?      ! Do we have this target in our database ?
548      
549      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
550      
551      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
552      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
553         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
# Line 1091  CONTAINS Line 557  CONTAINS
557         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
558      ENDIF      ENDIF
559      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)      tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
560      
561      IF (pos < 0) THEN      IF (pos < 0) THEN
562         !-- Ge the information out of the file         ! Ge the information out of the file
563         CALL getfill (TARGET,status,fileorig,tmp_ret_val)         CALL getfill(MY_TARGET, status, fileorig, tmp_ret_val)
564         !-- Put the data into the database         ! Put the data into the database
565         CALL getdbwl &         CALL getdbwl &
566              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
567      ELSE      ELSE
568         !-- Get the value out of the database         ! Get the value out of the database
569         CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbrl (pos, size_of_in, MY_TARGET, tmp_ret_val)
570      ENDIF      ENDIF
571      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)      ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
572      !----------------------  
573    END SUBROUTINE getinl1d    END SUBROUTINE getinl1d
574    
575    !****************************    !****************************
576    
577    SUBROUTINE getinl2d (TARGET,ret_val)    SUBROUTINE getinl2d(MY_TARGET, ret_val)
578      !---------------------------------------------------------------------  
579      !- See getinls for details. It is the same thing but for a matrix      ! See getinls for details. It is the same thing but for a matrix
580      !---------------------------------------------------------------------  
581      
582      CHARACTER(LEN=*) :: TARGET      CHARACTER(LEN=*) :: MY_TARGET
583      LOGICAL,DIMENSION(:,:) :: ret_val      LOGICAL, DIMENSION(:, :) :: ret_val
584      
585      LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val      LOGICAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val
586      INTEGER,SAVE :: tmp_ret_size = 0      INTEGER, SAVE :: tmp_ret_size = 0
587      INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig      INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig
588      INTEGER :: jl,jj,ji      INTEGER :: jl, jj, ji
589      !---------------------------------------------------------------------  
590      
591      ! Compute the signature of the target      ! Compute the signature of the target
592      
593      CALL gensig (TARGET,target_sig)      CALL gensig(MY_TARGET, target_sig)
594      
595      ! Do we have this target in our database ?      ! Do we have this target in our database ?
596      
597      CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)      CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos)
598      
599      size_of_in = SIZE(ret_val)      size_of_in = SIZE(ret_val)
600      size_1 = SIZE(ret_val,1)      size_1 = SIZE(ret_val, 1)
601      size_2 = SIZE(ret_val,2)      size_2 = SIZE(ret_val, 2)
602      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN      IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
603         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
604      ELSE IF (size_of_in > tmp_ret_size) THEN      ELSE IF (size_of_in > tmp_ret_size) THEN
# Line 1140  CONTAINS Line 606  CONTAINS
606         ALLOCATE (tmp_ret_val(size_of_in))         ALLOCATE (tmp_ret_val(size_of_in))
607         tmp_ret_size = size_of_in         tmp_ret_size = size_of_in
608      ENDIF      ENDIF
609      
610      jl=0      jl=0
611      DO jj=1,size_2      DO jj=1, size_2
612         DO ji=1,size_1         DO ji=1, size_1
613            jl=jl+1            jl=jl+1
614            tmp_ret_val(jl) = ret_val(ji,jj)            tmp_ret_val(jl) = ret_val(ji, jj)
615         ENDDO         ENDDO
616      ENDDO      ENDDO
617      
618      IF (pos < 0) THEN      IF (pos < 0) THEN
619         !-- Ge the information out of the file         ! Ge the information out of the file
620         CALL getfill (TARGET,status,fileorig,tmp_ret_val)         CALL getfill(MY_TARGET, status, fileorig, tmp_ret_val)
621         !-- Put the data into the database         ! Put the data into the database
622         CALL getdbwl &         CALL getdbwl &
623              &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)              & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
624      ELSE      ELSE
625         !-- Get the value out of the database         ! Get the value out of the database
626         CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val)         CALL getdbrl (pos, size_of_in, MY_TARGET, tmp_ret_val)
627      ENDIF      ENDIF
628      
629      jl=0      jl=0
630      DO jj=1,size_2      DO jj=1, size_2
631         DO ji=1,size_1         DO ji=1, size_1
632            jl=jl+1            jl=jl+1
633            ret_val(ji,jj) = tmp_ret_val(jl)            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  
     !---------------------------------------------------------------------  
     
     CHARACTER(LEN=*) :: TARGET  
     INTEGER :: status, fileorig  
     LOGICAL,DIMENSION(:) :: ret_val  
     
     INTEGER :: nb_to_ret  
     INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, status_cnt  
     CHARACTER(LEN=3)  :: cnt  
     CHARACTER(LEN=30) :: full_target  
     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp  
     INTEGER :: full_target_sig  
     
     INTEGER,SAVE :: max_len = 0  
     LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found  
     LOGICAL :: def_beha  
     !---------------------------------------------------------------------  
     nb_to_ret = SIZE(ret_val)  
     CALL getin_read  
     
     ! Get the variables and memory we need  
     
     IF (max_len == 0) THEN  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     IF (max_len < nb_to_ret) THEN  
        DEALLOCATE(found)  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     found(:) = .FALSE.  
     
     ! See what we find in the files read  
     
     DO it=1,nb_to_ret  
        !---  
        !-- First try the target as it is  
        !---  
        full_target = TARGET(1:len_TRIM(target))  
        CALL gensig (full_target,full_target_sig)  
        CALL find_sig (nb_lines,targetlist,full_target, &  
             &                 targetsiglist,full_target_sig,pos)  
        !---  
        !-- Another try  
        !---  
        IF (pos < 0) THEN  
           WRITE(cnt,'(I3.3)') it  
           full_target = TARGET(1:len_TRIM(target))//'__'//cnt  
           CALL gensig (full_target,full_target_sig)  
           CALL find_sig (nb_lines,targetlist,full_target, &  
                &                   targetsiglist,full_target_sig,pos)  
        ENDIF  
        !---  
        !-- A priori we dont know from which file the target could come.  
        !-- Thus by default we attribute it to the first file :  
        !---  
        fileorig = 1  
        !---  
        IF (pos > 0) THEN  
           !-----  
           found(it) = .TRUE.  
           fileorig = fromfile(pos)  
           !-----  
           !---- DECODE  
           !-----  
           str_READ = TRIM(ADJUSTL(fichier(pos)))  
           str_READ_lower = str_READ  
           CALL strlowercase (str_READ_lower)  
           !-----  
           IF (    (     (INDEX(str_READ_lower,'def') == 1)     &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &  
                &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN  
              def_beha = .TRUE.  
           ELSE  
              def_beha = .FALSE.  
              len_str = LEN_TRIM(str_READ)  
              ipos_tr = -1  
              ipos_fl = -1  
              !-------  
              ipos_tr = MAX(INDEX(str_READ,'tru'),INDEX(str_READ,'TRU'), &  
                   &                    INDEX(str_READ,'y'),INDEX(str_READ,'Y'))  
              ipos_fl = MAX(INDEX(str_READ,'fal'),INDEX(str_READ,'FAL'), &  
                   &                    INDEX(str_READ,'n'),INDEX(str_READ,'N'))  
              !-------  
              IF (ipos_tr > 0) THEN  
                 ret_val(it) = .TRUE.  
              ELSE IF (ipos_fl > 0) THEN  
                 ret_val(it) = .FALSE.  
              ELSE  
                 WRITE(*,*) "ERROR : getfill : TARGET ", &  
                      &                   TRIM(TARGET)," is not of logical value"  
                 STOP 'getinl'  
              ENDIF  
           ENDIF  
           !-----  
           targetsiglist(pos) = -1  
           !-----  
        ELSE  
           
           found(it) = .FALSE.  
           
        ENDIF  
       
     ENDDO  
     
     ! Now we get the status for what we found  
     
     IF (def_beha) THEN  
        status = 2  
        WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)  
     ELSE  
        status_cnt = 0  
        DO it=1,nb_to_ret  
           IF (.NOT. found(it)) THEN  
              status_cnt = status_cnt+1  
              IF (nb_to_ret > 1) THEN  
                 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it  
              ELSE  
                 str_tmp = TRIM(TARGET)  
              ENDIF  
              WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)  
           ENDIF  
        ENDDO  
        !---  
        IF (status_cnt == 0) THEN  
           status = 1  
        ELSE IF (status_cnt == nb_to_ret) THEN  
           status = 2  
        ELSE  
           status = 3  
        ENDIF  
     ENDIF  
     !---------------------  
   END SUBROUTINE getfill  
   
   !****************************  
   
   SUBROUTINE getin_read  
     !---------------------------------------------------------------------  
     
     INTEGER,SAVE :: allread=0  
     INTEGER,SAVE :: current  
     !---------------------------------------------------------------------  
     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.  
     !---------------------------------------------------------------------  
     
     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.  
     !---------------------------------------------------------------------  
     
     ! 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)),' ')  
634         ENDDO         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.  
     !---------------------------------------------------------------------  
     
     ! 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  
635      ENDDO      ENDDO
     
   END SUBROUTINE getin_checkcohe  
   
   !****************************  
   
   SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)  
     !---------------------------------------------------------------------  
     
     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  
     !---------------------------------------------------------------------  
     
     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  
     !---------------------------------------------------------------------  
     
     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  
     !---------------------------------------------------------------------  
     
     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  
     !---------------------------------------------------------------------  
     
     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  
636    
637    SUBROUTINE getdbwc &    END SUBROUTINE getinl2d
        &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)  
     !---------------------------------------------------------------------  
     !- Write the CHARACTER data into the data base  
     !---------------------------------------------------------------------  
     
     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  
     !---------------------------------------------------------------------  
     
     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  
     !---------------------------------------------------------------------  
     
     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  
     !---------------------------------------------------------------------  
     
     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  
   
     INTEGER,ALLOCATABLE :: tmp_int(:)  
     CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:)  
   
     !---------------------------------------------------------------------  
   
     !!print *, "Call sequence information: getin_allockeys"  
     ! Either nothing exists in these arrays and it is easy to do  
   
     IF (keymemsize == 0) THEN  
        ALLOCATE(keysig(memslabs))  
        ALLOCATE(keystr(memslabs))  
        ALLOCATE(keystatus(memslabs))  
        ALLOCATE(keytype(memslabs))  
        ALLOCATE(keycompress(memslabs))  
        ALLOCATE(keyfromfile(memslabs))  
        ALLOCATE(keymemstart(memslabs))  
        ALLOCATE(keymemlen(memslabs))  
        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))  
   
        ALLOCATE(tmp_int(keymemsize))  
        tmp_int(1:keymemsize) = keysig(1:keymemsize)  
   
        DEALLOCATE(keysig)  
        ALLOCATE(keysig(keymemsize+memslabs))  
        keysig(1:keymemsize) = tmp_int(1:keymemsize)  
   
        tmp_str(1:keymemsize) = keystr(1:keymemsize)  
        DEALLOCATE(keystr)  
        ALLOCATE(keystr(keymemsize+memslabs))  
        keystr(1:keymemsize) = tmp_str(1:keymemsize)  
   
        tmp_int(1:keymemsize) = keystatus(1:keymemsize)  
        DEALLOCATE(keystatus)  
        ALLOCATE(keystatus(keymemsize+memslabs))  
        keystatus(1:keymemsize) = tmp_int(1:keymemsize)  
   
        tmp_int(1:keymemsize) = keytype(1:keymemsize)  
        DEALLOCATE(keytype)  
        ALLOCATE(keytype(keymemsize+memslabs))  
        keytype(1:keymemsize) = tmp_int(1:keymemsize)  
   
        tmp_int(1:keymemsize) = keycompress(1:keymemsize)  
        DEALLOCATE(keycompress)  
        ALLOCATE(keycompress(keymemsize+memslabs))  
        keycompress(:) = -1  
        keycompress(1:keymemsize) = tmp_int(1:keymemsize)  
   
        tmp_int(1:keymemsize) = keyfromfile(1:keymemsize)  
        DEALLOCATE(keyfromfile)  
        ALLOCATE(keyfromfile(keymemsize+memslabs))  
        keyfromfile(1:keymemsize) = tmp_int(1:keymemsize)  
   
        tmp_int(1:keymemsize) = keymemstart(1:keymemsize)  
        DEALLOCATE(keymemstart)  
        ALLOCATE(keymemstart(keymemsize+memslabs))  
        keymemstart(1:keymemsize) = tmp_int(1:keymemsize)  
   
        tmp_int(1:keymemsize) = keymemlen(1:keymemsize)  
        DEALLOCATE(keymemlen)  
        ALLOCATE(keymemlen(keymemsize+memslabs))  
        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  
     !---------------------------------------------------------------------  
     
     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  
638    
639  END MODULE getincom  END MODULE getincom
Legend:
Removed from v.32  
changed lines
  Added in v.51
  ViewVC Help
Powered by ViewVC 1.1.21