source: IOIPSL/trunk/src/getincom.f90 @ 1375

Last change on this file since 1375 was 1375, checked in by mmaipsl, 11 years ago

Because of undefined value on test at line 811 on compline (line compression
parameter), I add this property on the whole values of a vector parameter
readed by getincom.

  • Property svn:keywords set to Id
File size: 63.5 KB
Line 
1MODULE getincom
2!-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!---------------------------------------------------------------------
8USE errioipsl, ONLY : ipslerr,ipsldbg
9USE stringop, &
10 &   ONLY : nocomma,cmpblank,strlowercase
11!-
12IMPLICIT NONE
13!-
14PRIVATE
15PUBLIC :: getin_name, getin, getin_dump
16!-
17!!--------------------------------------------------------------------
18!! The "getin_name" routine allows the user to change the name
19!! of the definition file in which the data will be read.
20!! ("run.def" by default)
21!!
22!!  SUBROUTINE getin_name (file_name)
23!!
24!! OPTIONAL INPUT argument
25!!
26!! (C) file_name :  the name of the file
27!!                  in which the data will be read
28!!--------------------------------------------------------------------
29!-
30!-
31INTERFACE getin
32!!--------------------------------------------------------------------
33!! The "getin" routines get a variable.
34!! We first check if we find it in the database
35!! and if not we get it from the definition file.
36!!
37!! SUBROUTINE getin (targetname,ret_val)
38!!
39!! INPUT
40!!
41!! (C) targetname : Name of the variable
42!!
43!! OUTPUT
44!!
45!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
46!!                     that will contain the (standard)
47!!                     integer/real/character/logical values
48!!--------------------------------------------------------------------
49  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
50 &                 getinis, getini1d, getini2d, &
51 &                 getincs, getinc1d, getinc2d, &
52 &                 getinls, getinl1d, getinl2d
53END INTERFACE
54!-
55!!--------------------------------------------------------------------
56!! The "getin_dump" routine will dump the content of the database
57!! into a file which has the same format as the definition file.
58!! The idea is that the user can see which parameters were used
59!! and re-use the file for another run.
60!!
61!!  SUBROUTINE getin_dump (fileprefix)
62!!
63!! OPTIONAL INPUT argument
64!!
65!! (C) fileprefix : allows the user to change the name of the file
66!!                  in which the data will be archived
67!!--------------------------------------------------------------------
68!-
69  INTEGER,PARAMETER :: max_files=100
70  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
71  INTEGER,SAVE      :: nbfiles
72!-
73  INTEGER,SAVE :: allread=0
74  CHARACTER(LEN=100),SAVE :: def_file = 'run.def'
75!-
76  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
77  INTEGER,SAVE :: nb_lines,i_txtsize=0
78  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
79  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
80  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
81!-
82  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
83  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
84!-
85! The data base of parameters
86!-
87  INTEGER,PARAMETER :: memslabs=200
88  INTEGER,PARAMETER :: compress_lim=20
89!-
90  INTEGER,SAVE :: nb_keys=0
91  INTEGER,SAVE :: keymemsize=0
92!-
93! keystr definition
94! name of a key
95!-
96! keystatus definition
97! keystatus = 1 : Value comes from the file defined by 'def_file'
98! keystatus = 2 : Default value is used
99! keystatus = 3 : Some vector elements were taken from default
100  INTEGER,PARAMETER :: nondefault=1, default=2, vectornondefault=3
101!-
102! keytype definition
103! keytype = 1 : Integer
104! keytype = 2 : Real
105! keytype = 3 : Character
106! keytype = 4 : Logical
107!-
108  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
109!-
110! Allow compression for keys (only for integer and real)
111! keycompress < 0 : not compressed
112! keycompress > 0 : number of repeat of the value
113!-
114TYPE :: t_key
115  CHARACTER(LEN=l_n) :: keystr
116  INTEGER :: keystatus, keytype, keycompress, &
117 &           keyfromfile, keymemstart, keymemlen
118END TYPE t_key
119!-
120  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
121!-
122  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
123  INTEGER,SAVE :: i_memsize=0, i_mempos=0
124  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
125  INTEGER,SAVE :: r_memsize=0, r_mempos=0
126  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
127  INTEGER,SAVE :: c_memsize=0, c_mempos=0
128  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
129  INTEGER,SAVE :: l_memsize=0, l_mempos=0
130!-
131CONTAINS
132!-
133!=== DEFINITION FILE NAME INTERFACE
134!-
135SUBROUTINE getin_name (cname)
136!---------------------------------------------------------------------
137  IMPLICIT NONE
138!-
139  CHARACTER(LEN=*) :: cname
140!---------------------------------------------------------------------
141  IF (allread == 0) THEN
142    def_file = ADJUSTL(cname)
143  ELSE
144    CALL ipslerr (3,'getin_name', &
145 &   'The name of the database file (any_name.def)', &
146 &   'must be changed *before* any attempt','to read the database.')
147  ENDIF
148!------------------------
149END SUBROUTINE getin_name
150!-
151!=== INTEGER INTERFACE
152!-
153SUBROUTINE getinis (targetname,ret_val)
154!---------------------------------------------------------------------
155  IMPLICIT NONE
156!-
157  CHARACTER(LEN=*) :: targetname
158  INTEGER :: ret_val
159!-
160  INTEGER,DIMENSION(1) :: tmp_ret_val
161  INTEGER :: pos,status=0,fileorig, size_of_in
162!---------------------------------------------------------------------
163!-
164! Do we have this targetname in our database ?
165!-
166  CALL get_findkey (1,targetname,pos)
167!-
168  tmp_ret_val(1) = ret_val
169  size_of_in = SIZE(tmp_ret_val)
170 
171!-
172  IF (pos < 0) THEN
173!-- Get the information out of the file
174    CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
175!-- Put the data into the database
176    CALL get_wdb &
177 &   (targetname,status,fileorig,1,i_val=tmp_ret_val)
178  ELSE
179!-- Get the value out of the database
180    CALL get_rdb (pos,1,targetname,i_val=tmp_ret_val)
181  ENDIF
182  ret_val = tmp_ret_val(1)
183!---------------------
184END SUBROUTINE getinis
185!===
186SUBROUTINE getini1d (targetname,ret_val)
187!---------------------------------------------------------------------
188  IMPLICIT NONE
189!-
190  CHARACTER(LEN=*) :: targetname
191  INTEGER,DIMENSION(:) :: ret_val
192!-
193  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
194  INTEGER,SAVE :: tmp_ret_size = 0
195  INTEGER :: pos,size_of_in,status=0,fileorig
196!---------------------------------------------------------------------
197!-
198! Do we have this targetname in our database ?
199!-
200  CALL get_findkey (1,targetname,pos)
201!-
202  size_of_in = SIZE(ret_val)
203  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
204    ALLOCATE (tmp_ret_val(size_of_in))
205  ELSE IF (size_of_in > tmp_ret_size) THEN
206    DEALLOCATE (tmp_ret_val)
207    ALLOCATE (tmp_ret_val(size_of_in))
208    tmp_ret_size = size_of_in
209  ENDIF
210  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
211!-
212  IF (pos < 0) THEN
213!-- Get the information out of the file
214    CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
215!-- Put the data into the database
216    CALL get_wdb &
217 &   (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
218  ELSE
219!-- Get the value out of the database
220    CALL get_rdb (pos,size_of_in,targetname,i_val=tmp_ret_val)
221  ENDIF
222  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
223!----------------------
224END SUBROUTINE getini1d
225!===
226SUBROUTINE getini2d (targetname,ret_val)
227!---------------------------------------------------------------------
228  IMPLICIT NONE
229!-
230  CHARACTER(LEN=*) :: targetname
231  INTEGER,DIMENSION(:,:) :: ret_val
232!-
233  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
234  INTEGER,SAVE :: tmp_ret_size = 0
235  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
236  INTEGER :: jl,jj,ji
237!---------------------------------------------------------------------
238!-
239! Do we have this targetname in our database ?
240!-
241  CALL get_findkey (1,targetname,pos)
242!-
243  size_of_in = SIZE(ret_val)
244  size_1 = SIZE(ret_val,1)
245  size_2 = SIZE(ret_val,2)
246  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
247    ALLOCATE (tmp_ret_val(size_of_in))
248  ELSE IF (size_of_in > tmp_ret_size) THEN
249    DEALLOCATE (tmp_ret_val)
250    ALLOCATE (tmp_ret_val(size_of_in))
251    tmp_ret_size = size_of_in
252  ENDIF
253!-
254  jl=0
255  DO jj=1,size_2
256    DO ji=1,size_1
257      jl=jl+1
258      tmp_ret_val(jl) = ret_val(ji,jj)
259    ENDDO
260  ENDDO
261!-
262  IF (pos < 0) THEN
263!-- Get the information out of the file
264    CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
265!-- Put the data into the database
266    CALL get_wdb &
267 &   (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
268  ELSE
269!-- Get the value out of the database
270    CALL get_rdb (pos,size_of_in,targetname,i_val=tmp_ret_val)
271  ENDIF
272!-
273  jl=0
274  DO jj=1,size_2
275    DO ji=1,size_1
276      jl=jl+1
277      ret_val(ji,jj) = tmp_ret_val(jl)
278    ENDDO
279  ENDDO
280!----------------------
281END SUBROUTINE getini2d
282!-
283!=== REAL INTERFACE
284!-
285SUBROUTINE getinrs (targetname,ret_val)
286!---------------------------------------------------------------------
287  IMPLICIT NONE
288!-
289  CHARACTER(LEN=*) :: targetname
290  REAL :: ret_val
291!-
292  REAL,DIMENSION(1) :: tmp_ret_val
293  INTEGER :: pos,status=0,fileorig, size_of_in
294!---------------------------------------------------------------------
295!-
296! Do we have this targetname in our database ?
297!-
298  CALL get_findkey (1,targetname,pos)
299!-
300  tmp_ret_val(1) = ret_val
301  size_of_in = SIZE(tmp_ret_val)
302!-
303  IF (pos < 0) THEN
304!-- Get the information out of the file
305    CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
306!-- Put the data into the database
307    CALL get_wdb &
308 &   (targetname,status,fileorig,1,r_val=tmp_ret_val)
309  ELSE
310!-- Get the value out of the database
311    CALL get_rdb (pos,1,targetname,r_val=tmp_ret_val)
312  ENDIF
313  ret_val = tmp_ret_val(1)
314!---------------------
315END SUBROUTINE getinrs
316!===
317SUBROUTINE getinr1d (targetname,ret_val)
318!---------------------------------------------------------------------
319  IMPLICIT NONE
320!-
321  CHARACTER(LEN=*) :: targetname
322  REAL,DIMENSION(:) :: ret_val
323!-
324  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
325  INTEGER,SAVE :: tmp_ret_size = 0
326  INTEGER :: pos,size_of_in,status=0,fileorig
327!---------------------------------------------------------------------
328!-
329! Do we have this targetname in our database ?
330!-
331  CALL get_findkey (1,targetname,pos)
332!-
333  size_of_in = SIZE(ret_val)
334  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
335    ALLOCATE (tmp_ret_val(size_of_in))
336  ELSE IF (size_of_in > tmp_ret_size) THEN
337    DEALLOCATE (tmp_ret_val)
338    ALLOCATE (tmp_ret_val(size_of_in))
339    tmp_ret_size = size_of_in
340  ENDIF
341  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
342!-
343  IF (pos < 0) THEN
344!-- Get the information out of the file
345    CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
346!-- Put the data into the database
347    CALL get_wdb &
348 &   (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
349  ELSE
350!-- Get the value out of the database
351    CALL get_rdb (pos,size_of_in,targetname,r_val=tmp_ret_val)
352  ENDIF
353  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
354!----------------------
355END SUBROUTINE getinr1d
356!===
357SUBROUTINE getinr2d (targetname,ret_val)
358!---------------------------------------------------------------------
359  IMPLICIT NONE
360!-
361  CHARACTER(LEN=*) :: targetname
362  REAL,DIMENSION(:,:) :: ret_val
363!-
364  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
365  INTEGER,SAVE :: tmp_ret_size = 0
366  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
367  INTEGER :: jl,jj,ji
368!---------------------------------------------------------------------
369!-
370! Do we have this targetname in our database ?
371!-
372  CALL get_findkey (1,targetname,pos)
373!-
374  size_of_in = SIZE(ret_val)
375  size_1 = SIZE(ret_val,1)
376  size_2 = SIZE(ret_val,2)
377  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
378    ALLOCATE (tmp_ret_val(size_of_in))
379  ELSE IF (size_of_in > tmp_ret_size) THEN
380    DEALLOCATE (tmp_ret_val)
381    ALLOCATE (tmp_ret_val(size_of_in))
382    tmp_ret_size = size_of_in
383  ENDIF
384!-
385  jl=0
386  DO jj=1,size_2
387    DO ji=1,size_1
388      jl=jl+1
389      tmp_ret_val(jl) = ret_val(ji,jj)
390    ENDDO
391  ENDDO
392!-
393  IF (pos < 0) THEN
394!-- Get the information out of the file
395    CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
396!-- Put the data into the database
397    CALL get_wdb &
398 &   (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
399  ELSE
400!-- Get the value out of the database
401    CALL get_rdb (pos,size_of_in,targetname,r_val=tmp_ret_val)
402  ENDIF
403!-
404  jl=0
405  DO jj=1,size_2
406    DO ji=1,size_1
407      jl=jl+1
408      ret_val(ji,jj) = tmp_ret_val(jl)
409    ENDDO
410  ENDDO
411!----------------------
412END SUBROUTINE getinr2d
413!-
414!=== CHARACTER INTERFACE
415!-
416SUBROUTINE getincs (targetname,ret_val)
417!---------------------------------------------------------------------
418  IMPLICIT NONE
419!-
420  CHARACTER(LEN=*) :: targetname
421  CHARACTER(LEN=*) :: ret_val
422!-
423  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
424  INTEGER :: pos,status=0,fileorig,size_of_in
425!---------------------------------------------------------------------
426!-
427! Do we have this targetname in our database ?
428!-
429  CALL get_findkey (1,targetname,pos)
430!-
431  tmp_ret_val(1) = ret_val
432  size_of_in = SIZE(tmp_ret_val)
433!-
434  IF (pos < 0) THEN
435!-- Get the information out of the file
436    CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
437!-- Put the data into the database
438    CALL get_wdb &
439 &   (targetname,status,fileorig,1,c_val=tmp_ret_val)
440  ELSE
441!-- Get the value out of the database
442    CALL get_rdb (pos,1,targetname,c_val=tmp_ret_val)
443  ENDIF
444  ret_val = tmp_ret_val(1)
445!---------------------
446END SUBROUTINE getincs
447!===
448SUBROUTINE getinc1d (targetname,ret_val)
449!---------------------------------------------------------------------
450  IMPLICIT NONE
451!-
452  CHARACTER(LEN=*) :: targetname
453  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
454!-
455  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
456  INTEGER,SAVE :: tmp_ret_size = 0
457  INTEGER :: pos,size_of_in,status=0,fileorig
458!---------------------------------------------------------------------
459!-
460! Do we have this targetname in our database ?
461!-
462  CALL get_findkey (1,targetname,pos)
463!-
464  size_of_in = SIZE(ret_val)
465  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
466    ALLOCATE (tmp_ret_val(size_of_in))
467  ELSE IF (size_of_in > tmp_ret_size) THEN
468    DEALLOCATE (tmp_ret_val)
469    ALLOCATE (tmp_ret_val(size_of_in))
470    tmp_ret_size = size_of_in
471  ENDIF
472  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
473!-
474  IF (pos < 0) THEN
475!-- Get the information out of the file
476    CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
477!-- Put the data into the database
478    CALL get_wdb &
479 &   (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
480  ELSE
481!-- Get the value out of the database
482    CALL get_rdb (pos,size_of_in,targetname,c_val=tmp_ret_val)
483  ENDIF
484  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
485!----------------------
486END SUBROUTINE getinc1d
487!===
488SUBROUTINE getinc2d (targetname,ret_val)
489!---------------------------------------------------------------------
490  IMPLICIT NONE
491!-
492  CHARACTER(LEN=*) :: targetname
493  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
494!-
495  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
496  INTEGER,SAVE :: tmp_ret_size = 0
497  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
498  INTEGER :: jl,jj,ji
499!---------------------------------------------------------------------
500!-
501! Do we have this targetname in our database ?
502!-
503  CALL get_findkey (1,targetname,pos)
504!-
505  size_of_in = SIZE(ret_val)
506  size_1 = SIZE(ret_val,1)
507  size_2 = SIZE(ret_val,2)
508  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
509    ALLOCATE (tmp_ret_val(size_of_in))
510  ELSE IF (size_of_in > tmp_ret_size) THEN
511    DEALLOCATE (tmp_ret_val)
512    ALLOCATE (tmp_ret_val(size_of_in))
513    tmp_ret_size = size_of_in
514  ENDIF
515!-
516  jl=0
517  DO jj=1,size_2
518    DO ji=1,size_1
519      jl=jl+1
520      tmp_ret_val(jl) = ret_val(ji,jj)
521    ENDDO
522  ENDDO
523!-
524  IF (pos < 0) THEN
525!-- Get the information out of the file
526    CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
527!-- Put the data into the database
528    CALL get_wdb &
529 &   (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
530  ELSE
531!-- Get the value out of the database
532    CALL get_rdb (pos,size_of_in,targetname,c_val=tmp_ret_val)
533  ENDIF
534!-
535  jl=0
536  DO jj=1,size_2
537    DO ji=1,size_1
538      jl=jl+1
539      ret_val(ji,jj) = tmp_ret_val(jl)
540    ENDDO
541  ENDDO
542!----------------------
543END SUBROUTINE getinc2d
544!-
545!=== LOGICAL INTERFACE
546!-
547SUBROUTINE getinls (targetname,ret_val)
548!---------------------------------------------------------------------
549  IMPLICIT NONE
550!-
551  CHARACTER(LEN=*) :: targetname
552  LOGICAL :: ret_val
553!-
554  LOGICAL,DIMENSION(1) :: tmp_ret_val
555  INTEGER :: pos,status=0,fileorig,size_of_in
556!---------------------------------------------------------------------
557!-
558! Do we have this targetname in our database ?
559!-
560  CALL get_findkey (1,targetname,pos)
561!-
562  tmp_ret_val(1) = ret_val
563  size_of_in = SIZE(tmp_ret_val)
564!-
565  IF (pos < 0) THEN
566!-- Get the information out of the file
567    CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
568!-- Put the data into the database
569    CALL get_wdb &
570 &   (targetname,status,fileorig,1,l_val=tmp_ret_val)
571  ELSE
572!-- Get the value out of the database
573    CALL get_rdb (pos,1,targetname,l_val=tmp_ret_val)
574  ENDIF
575  ret_val = tmp_ret_val(1)
576!---------------------
577END SUBROUTINE getinls
578!===
579SUBROUTINE getinl1d (targetname,ret_val)
580!---------------------------------------------------------------------
581  IMPLICIT NONE
582!-
583  CHARACTER(LEN=*) :: targetname
584  LOGICAL,DIMENSION(:) :: ret_val
585!-
586  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
587  INTEGER,SAVE :: tmp_ret_size = 0
588  INTEGER :: pos,size_of_in,status=0,fileorig
589!---------------------------------------------------------------------
590!-
591! Do we have this targetname in our database ?
592!-
593  CALL get_findkey (1,targetname,pos)
594!-
595  size_of_in = SIZE(ret_val)
596  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
597    ALLOCATE (tmp_ret_val(size_of_in))
598  ELSE IF (size_of_in > tmp_ret_size) THEN
599    DEALLOCATE (tmp_ret_val)
600    ALLOCATE (tmp_ret_val(size_of_in))
601    tmp_ret_size = size_of_in
602  ENDIF
603  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
604!-
605  IF (pos < 0) THEN
606!-- Get the information out of the file
607    CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
608!-- Put the data into the database
609    CALL get_wdb &
610 &   (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
611  ELSE
612!-- Get the value out of the database
613    CALL get_rdb (pos,size_of_in,targetname,l_val=tmp_ret_val)
614  ENDIF
615  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
616!----------------------
617END SUBROUTINE getinl1d
618!===
619SUBROUTINE getinl2d (targetname,ret_val)
620!---------------------------------------------------------------------
621  IMPLICIT NONE
622!-
623  CHARACTER(LEN=*) :: targetname
624  LOGICAL,DIMENSION(:,:) :: ret_val
625!-
626  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
627  INTEGER,SAVE :: tmp_ret_size = 0
628  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
629  INTEGER :: jl,jj,ji
630!---------------------------------------------------------------------
631!-
632! Do we have this targetname in our database ?
633!-
634  CALL get_findkey (1,targetname,pos)
635!-
636  size_of_in = SIZE(ret_val)
637  size_1 = SIZE(ret_val,1)
638  size_2 = SIZE(ret_val,2)
639  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
640    ALLOCATE (tmp_ret_val(size_of_in))
641  ELSE IF (size_of_in > tmp_ret_size) THEN
642    DEALLOCATE (tmp_ret_val)
643    ALLOCATE (tmp_ret_val(size_of_in))
644    tmp_ret_size = size_of_in
645  ENDIF
646!-
647  jl=0
648  DO jj=1,size_2
649    DO ji=1,size_1
650      jl=jl+1
651      tmp_ret_val(jl) = ret_val(ji,jj)
652    ENDDO
653  ENDDO
654!-
655  IF (pos < 0) THEN
656!-- Get the information out of the file
657    CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
658!-- Put the data into the database
659    CALL get_wdb &
660 &   (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
661  ELSE
662!-- Get the value out of the database
663    CALL get_rdb (pos,size_of_in,targetname,l_val=tmp_ret_val)
664  ENDIF
665!-
666  jl=0
667  DO jj=1,size_2
668    DO ji=1,size_1
669      jl=jl+1
670      ret_val(ji,jj) = tmp_ret_val(jl)
671    ENDDO
672  ENDDO
673!----------------------
674END SUBROUTINE getinl2d
675!-
676!=== Generic file/database INTERFACE
677!-
678SUBROUTINE get_fil (targetname,status,fileorig,nb_to_ret,i_val,r_val,c_val,l_val)
679!---------------------------------------------------------------------
680!- Subroutine that will extract from the file the values
681!- attributed to the keyword targetname
682!-
683!- (C) targetname    : target for which we will look in the file
684!- (I) status    : tells us from where we obtained the data
685!- (I) fileorig  : index of the file from which the key comes
686!- (I) nb_to_ret : size of output vector
687!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
688!- (R) r_val(:)  : REAL(nb_to_ret)      values
689!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
690!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
691!---------------------------------------------------------------------
692  IMPLICIT NONE
693!-
694  CHARACTER(LEN=*) :: targetname
695  INTEGER,INTENT(IN) :: nb_to_ret
696  INTEGER,INTENT(OUT) :: status,fileorig
697  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
698  REAL,DIMENSION(:),OPTIONAL             :: r_val
699  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
700  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
701!-
702  INTEGER :: k_typ,it,pos,len_str,status_cnt,io_err
703  CHARACTER(LEN=n_d_fmt)  :: cnt
704  CHARACTER(LEN=80) :: str_READ,str_READ_lower
705  CHARACTER(LEN=9)  :: c_vtyp
706  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
707  LOGICAL :: def_beha,compressed
708  CHARACTER(LEN=10) :: c_fmt
709  INTEGER :: i_cmpval
710  REAL    :: r_cmpval
711  INTEGER :: ipos_tr,ipos_fl
712  LOGICAL :: l_dbg
713!---------------------------------------------------------------------
714  CALL ipsldbg (old_status=l_dbg)
715!---------------------------------------------------------------------
716!-
717! Get the type of the argument
718  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
719  IF ( (k_typ.NE.k_i) .AND. (k_typ.NE.k_r) .AND. (k_typ.NE.k_c) .AND. (k_typ.NE.k_l) ) THEN
720    CALL ipslerr (3,'get_fil', &
721 &   'Internal error','Unknown type of data',' ')
722  ENDIF
723!-
724! Read the file(s)
725  CALL getin_read
726!-
727! Allocate and initialize the memory we need
728  ALLOCATE(found(nb_to_ret))
729  found(:) = .FALSE.
730!-
731! See what we find in the files read
732!---
733!-- We dont know from which file the target could come.
734!-- Thus by default we attribute it to the first file :
735  fileorig = 1
736!-
737  DO it=1,nb_to_ret
738!---
739!-- First try the target as it is
740    CALL get_findkey (2,targetname,pos)
741!---
742!-- Another try
743!---
744    IF (pos < 0) THEN
745      WRITE(UNIT=cnt,FMT=c_i_fmt) it
746      CALL get_findkey (2,TRIM(targetname)//'__'//cnt,pos)
747    ENDIF
748!---
749    IF (pos > 0) THEN
750!-----
751      found(it) = .TRUE.
752      fileorig = fromfile(pos)
753      !
754      IF (l_dbg) THEN
755         WRITE(*,*) &
756              &      'getin_fil : read key ',targetname,' from file ',fileorig,' has type ',k_typ
757      ENDIF
758!-----
759!---- DECODE
760!-----
761      str_READ = ADJUSTL(fichier(pos))
762      str_READ_lower = str_READ
763      CALL strlowercase (str_READ_lower)
764      IF (l_dbg) THEN
765         WRITE(*,*) &
766              &      '            value    ',str_READ_lower
767      ENDIF
768!-----
769      IF (    (TRIM(str_READ_lower) == 'def')     &
770 &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
771        def_beha = .TRUE.
772      ELSE
773        def_beha = .FALSE.
774        len_str = LEN_TRIM(str_READ)
775        io_err = 0
776        SELECT CASE (k_typ)
777        CASE(k_i)
778          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
779          READ (UNIT=str_READ(1:len_str), &
780 &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
781        CASE(k_r)
782          READ (UNIT=str_READ(1:len_str), &
783 &              FMT=*,IOSTAT=io_err) r_val(it)
784        CASE(k_c)
785          c_val(it) = str_READ(1:len_str)
786        CASE(k_l)
787          ipos_tr = -1
788          ipos_fl = -1
789          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
790 &                      INDEX(str_READ_lower,'y'))
791          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
792 &                      INDEX(str_READ_lower,'n'))
793          IF (ipos_tr > 0) THEN
794            l_val(it) = .TRUE.
795          ELSE IF (ipos_fl > 0) THEN
796            l_val(it) = .FALSE.
797          ELSE
798            io_err = 100
799          ENDIF
800        END SELECT
801        IF (io_err /= 0) THEN
802          CALL ipslerr (3,'get_fil', &
803 &         'Target '//TRIM(targetname), &
804 &         'is not of '//TRIM(c_vtyp)//' type',' ')
805        ENDIF
806      ENDIF
807!-----
808      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
809!-------
810!------ Is this the value of a compressed field ?
811        compressed = (compline(pos) > 0)
812        IF (compressed) THEN
813          IF (compline(pos) /= nb_to_ret) THEN
814            CALL ipslerr (2,'get_fil', &
815 &           'For key '//TRIM(targetname)//' we have a compressed field', &
816 &           'which does not have the right size.', &
817 &           'We will try to fix that.')
818          ENDIF
819          IF      (k_typ == k_i) THEN
820            i_cmpval = i_val(it)
821          ELSE IF (k_typ == k_r) THEN
822            r_cmpval = r_val(it)
823          ENDIF
824        ENDIF
825      ENDIF
826    ELSE
827      found(it) = .FALSE.
828      def_beha = .FALSE.
829      compressed = .FALSE.
830    ENDIF
831  ENDDO
832!-
833  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
834!---
835!-- If this is a compressed field then we will uncompress it
836    IF (compressed) THEN
837      DO it=1,nb_to_ret
838        IF (.NOT.found(it)) THEN
839          IF      (k_typ == k_i) THEN
840            i_val(it) = i_cmpval
841          ELSE IF (k_typ == k_r) THEN
842            r_val(it) = r_cmpval
843          ENDIF
844          found(it) = .TRUE.
845        ENDIF
846      ENDDO
847    ENDIF
848  ENDIF
849!-
850! Now we set the status for what we found
851  IF (def_beha) THEN
852    status = default
853    CALL ipslerr (1,'USING DEFAULT BEHAVIOUR FOR', &
854 &   TRIM(targetname),' ',' ')
855    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(targetname)
856  ELSE
857    status_cnt = 0
858    DO it=1,nb_to_ret
859      IF (.NOT.found(it)) THEN
860        status_cnt = status_cnt+1
861        IF      (status_cnt <= max_msgs) THEN
862          WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
863 &               ADVANCE='NO') TRIM(targetname)
864          IF (nb_to_ret > 1) THEN
865            WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
866            WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
867          ENDIF
868          SELECT CASE (k_typ)
869          CASE(k_i)
870            WRITE (UNIT=*,FMT=*) "=",i_val(it)
871          CASE(k_r)
872            WRITE (UNIT=*,FMT=*) "=",r_val(it)
873          CASE(k_c)
874            WRITE (UNIT=*,FMT=*) "=",c_val(it)
875          CASE(k_l)
876            WRITE (UNIT=*,FMT=*) "=",l_val(it)
877          END SELECT
878        ELSE IF (status_cnt == max_msgs+1) THEN
879          WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
880        ENDIF
881      ENDIF
882    ENDDO
883!---
884    IF (status_cnt == 0) THEN
885      status = nondefault
886    ELSE IF (status_cnt == nb_to_ret) THEN
887      status = default
888    ELSE
889      status = vectornondefault
890    ENDIF
891  ENDIF
892! Deallocate the memory
893  DEALLOCATE(found)
894!---------------------
895END SUBROUTINE get_fil
896!===
897SUBROUTINE get_rdb (pos,size_of_in,targetname,i_val,r_val,c_val,l_val)
898!---------------------------------------------------------------------
899!- Read the required variable in the database
900!---------------------------------------------------------------------
901  IMPLICIT NONE
902!-
903  INTEGER :: pos,size_of_in
904  CHARACTER(LEN=*) :: targetname
905  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
906  REAL,DIMENSION(:),OPTIONAL             :: r_val
907  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
908  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
909!-
910  INTEGER :: k_typ,k_beg,k_end
911  CHARACTER(LEN=9) :: c_vtyp
912!---------------------------------------------------------------------
913!-
914! Get the type of the argument
915  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
916  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
917 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
918    CALL ipslerr (3,'get_rdb', &
919 &   'Internal error','Unknown type of data',' ')
920  ENDIF
921!-
922  IF (key_tab(pos)%keytype /= k_typ) THEN
923    CALL ipslerr (3,'get_rdb', &
924 &   'Wrong data type for keyword '//TRIM(targetname), &
925 &   '(NOT '//TRIM(c_vtyp)//')',' ')
926  ENDIF
927!-
928  IF (key_tab(pos)%keycompress > 0) THEN
929    IF (    (key_tab(pos)%keycompress /= size_of_in) &
930 &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
931      CALL ipslerr (3,'get_rdb', &
932 &     'Wrong compression length','for keyword '//TRIM(targetname),' ')
933    ELSE
934      SELECT CASE (k_typ)
935      CASE(k_i)
936        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
937      CASE(k_r)
938        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
939      END SELECT
940    ENDIF
941  ELSE
942    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
943      CALL ipslerr (3,'get_rdb', &
944 &     'Wrong array length','for keyword '//TRIM(targetname),' ')
945    ELSE
946      k_beg = key_tab(pos)%keymemstart
947      k_end = k_beg+key_tab(pos)%keymemlen-1
948      SELECT CASE (k_typ)
949      CASE(k_i)
950        i_val(1:size_of_in) = i_mem(k_beg:k_end)
951      CASE(k_r)
952        r_val(1:size_of_in) = r_mem(k_beg:k_end)
953      CASE(k_c)
954        c_val(1:size_of_in) = c_mem(k_beg:k_end)
955      CASE(k_l)
956        l_val(1:size_of_in) = l_mem(k_beg:k_end)
957      END SELECT
958    ENDIF
959  ENDIF
960!---------------------
961END SUBROUTINE get_rdb
962!===
963SUBROUTINE get_wdb &
964 &  (targetname,status,fileorig,size_of_in, &
965 &   i_val,r_val,c_val,l_val)
966!---------------------------------------------------------------------
967!- Write data into the data base
968!---------------------------------------------------------------------
969  IMPLICIT NONE
970!-
971  CHARACTER(LEN=*) :: targetname
972  INTEGER :: status,fileorig,size_of_in
973  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
974  REAL,DIMENSION(:),OPTIONAL             :: r_val
975  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
976  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
977!-
978  INTEGER :: k_typ
979  CHARACTER(LEN=9) :: c_vtyp
980  INTEGER :: k_mempos,k_memsize,k_beg,k_end
981  LOGICAL :: l_cmp
982  LOGICAL :: l_dbg
983!---------------------------------------------------------------------
984  CALL ipsldbg (old_status=l_dbg)
985!---------------------------------------------------------------------
986!-
987! Get the type of the argument
988  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
989  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
990 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
991    CALL ipslerr (3,'get_wdb', &
992 &   'Internal error','Unknown type of data',' ')
993  ENDIF
994!-
995! First check if we have sufficiant space for the new key
996  IF (nb_keys+1 > keymemsize) THEN
997    CALL getin_allockeys ()
998  ENDIF
999!-
1000  SELECT CASE (k_typ)
1001  CASE(k_i)
1002    k_mempos = i_mempos; k_memsize = i_memsize;
1003    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
1004 &         .AND.(size_of_in > compress_lim)
1005  CASE(k_r)
1006    k_mempos = r_mempos; k_memsize = r_memsize;
1007    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
1008 &         .AND.(size_of_in > compress_lim)
1009  CASE(k_c)
1010    k_mempos = c_mempos; k_memsize = c_memsize;
1011    l_cmp = .FALSE.
1012  CASE(k_l)
1013    k_mempos = l_mempos; k_memsize = l_memsize;
1014    l_cmp = .FALSE.
1015  END SELECT
1016!-
1017! Fill out the items of the data base
1018  nb_keys = nb_keys+1
1019  key_tab(nb_keys)%keystr = targetname(1:MIN(LEN_TRIM(targetname),l_n))
1020  key_tab(nb_keys)%keystatus = status
1021  key_tab(nb_keys)%keytype = k_typ
1022  key_tab(nb_keys)%keyfromfile = fileorig
1023  key_tab(nb_keys)%keymemstart = k_mempos+1
1024  IF (l_cmp) THEN
1025    key_tab(nb_keys)%keycompress = size_of_in
1026    key_tab(nb_keys)%keymemlen = 1
1027  ELSE
1028    key_tab(nb_keys)%keycompress = -1
1029    key_tab(nb_keys)%keymemlen = size_of_in
1030  ENDIF
1031  IF (l_dbg) THEN
1032     WRITE(*,*) &
1033 &     "get_wdb : nb_keys ",nb_keys," key_tab keystr   ",key_tab(nb_keys)%keystr,&
1034 &                                       ",keystatus   ",key_tab(nb_keys)%keystatus,&
1035 &                                       ",keytype     ",key_tab(nb_keys)%keytype,&
1036 &                                       ",keycompress ",key_tab(nb_keys)%keycompress,&
1037 &                                       ",keyfromfile ",key_tab(nb_keys)%keyfromfile,&
1038 &                                       ",keymemstart ",key_tab(nb_keys)%keymemstart
1039  ENDIF
1040
1041!-
1042! Before writing the actual size lets see if we have the space
1043  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
1044 &    > k_memsize) THEN
1045    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
1046  ENDIF
1047!-
1048  k_beg = key_tab(nb_keys)%keymemstart
1049  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
1050  SELECT CASE (k_typ)
1051  CASE(k_i)
1052    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
1053    i_mempos = k_end
1054  CASE(k_r)
1055    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
1056    r_mempos = k_end
1057  CASE(k_c)
1058    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
1059    c_mempos = k_end
1060  CASE(k_l)
1061    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
1062    l_mempos = k_end
1063  END SELECT
1064!---------------------
1065END SUBROUTINE get_wdb
1066!-
1067!===
1068!-
1069SUBROUTINE getin_read
1070!---------------------------------------------------------------------
1071  IMPLICIT NONE
1072!-
1073  INTEGER,SAVE :: current
1074!---------------------------------------------------------------------
1075  IF (allread == 0) THEN
1076!-- Allocate a first set of memory.
1077    CALL getin_alloctxt ()
1078    CALL getin_allockeys ()
1079    CALL getin_allocmem (k_i,0)
1080    CALL getin_allocmem (k_r,0)
1081    CALL getin_allocmem (k_c,0)
1082    CALL getin_allocmem (k_l,0)
1083!-- Start with reading the files
1084    nbfiles = 1
1085    filelist(1) = TRIM(def_file)
1086    current = 1
1087!--
1088    DO WHILE (current <= nbfiles)
1089      CALL getin_readdef (current)
1090      current = current+1
1091    ENDDO
1092    allread = 1
1093    CALL getin_checkcohe ()
1094  ENDIF
1095!------------------------
1096END SUBROUTINE getin_read
1097!-
1098!===
1099!-
1100  SUBROUTINE getin_readdef(current)
1101!---------------------------------------------------------------------
1102!- This subroutine will read the files and only keep the
1103!- the relevant information. The information is kept as it
1104!- found in the file. The data will be analysed later.
1105!---------------------------------------------------------------------
1106  IMPLICIT NONE
1107!-
1108  INTEGER :: current
1109!-
1110  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
1111  CHARACTER(LEN=n_d_fmt) :: cnt
1112  CHARACTER(LEN=10) :: c_fmt
1113  INTEGER :: nb_lastkey
1114!-
1115  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
1116  LOGICAL :: l_dbg
1117!---------------------------------------------------------------------
1118  CALL ipsldbg (old_status=l_dbg)
1119!---------------------------------------------------------------------
1120  eof = 0
1121  ptn = 1
1122  nb_lastkey = 0
1123!-
1124  IF (l_dbg) THEN
1125    WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current))
1126  ENDIF
1127!-
1128  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
1129  IF (io_err /= 0) THEN
1130    CALL ipslerr (2,'getin_readdef', &
1131 &  'Could not open file '//TRIM(filelist(current)),' ',' ')
1132    RETURN
1133  ENDIF
1134!-
1135  DO WHILE (eof /= 1)
1136!---
1137    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
1138    len_str = LEN_TRIM(READ_str)
1139    ptn = INDEX(READ_str,'=')
1140!---
1141    IF (ptn > 0) THEN
1142!---- Get the target
1143      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
1144!---- Make sure that a vector keyword has the right length
1145      iund = INDEX(key_str,'__')
1146      IF (iund > 0) THEN
1147        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
1148 &        LEN_TRIM(key_str)-iund-1
1149        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
1150 &           FMT=c_fmt,IOSTAT=io_err) it
1151        IF ( (io_err == 0).AND.(it > 0) ) THEN
1152          WRITE(UNIT=cnt,FMT=c_i_fmt) it
1153          key_str = key_str(1:iund+1)//cnt
1154        ELSE
1155          CALL ipslerr (3,'getin_readdef', &
1156 &         'A very strange key has just been found :', &
1157 &         TRIM(key_str),' ')
1158        ENDIF
1159      ENDIF
1160!---- Prepare the content
1161      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
1162      CALL nocomma (NEW_str)
1163      CALL cmpblank (NEW_str)
1164      NEW_str  = TRIM(ADJUSTL(NEW_str))
1165      IF (l_dbg) THEN
1166        WRITE(*,*) &
1167 &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
1168      ENDIF
1169!---- Decypher the content of NEW_str
1170!-
1171!---- This has to be a new key word, thus :
1172      nb_lastkey = 0
1173!----
1174      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
1175!----
1176    ELSE IF (len_str > 0) THEN
1177!---- Prepare the key if we have an old one to which
1178!---- we will add the line just read
1179      IF (nb_lastkey > 0) THEN
1180        iund =  INDEX(last_key,'__')
1181        IF (iund > 0) THEN
1182!-------- We only continue a keyword, thus it is easy
1183          key_str = last_key(1:iund-1)
1184        ELSE
1185          IF (nb_lastkey /= 1) THEN
1186            CALL ipslerr (3,'getin_readdef', &
1187 &           'We can not have a scalar keyword', &
1188 &           'and a vector content',' ')
1189          ENDIF
1190!-------- The last keyword needs to be transformed into a vector.
1191          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
1192          targetlist(nb_lines) = &
1193 &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
1194          key_str = last_key(1:LEN_TRIM(last_key))
1195        ENDIF
1196      ENDIF
1197!---- Prepare the content
1198      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
1199      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
1200    ELSE
1201!---- If we have an empty line then the keyword finishes
1202      nb_lastkey = 0
1203      IF (l_dbg) THEN
1204        WRITE(*,*) 'getin_readdef : Have found an emtpy line '
1205      ENDIF
1206    ENDIF
1207  ENDDO
1208!-
1209  CLOSE(UNIT=22)
1210!-
1211  IF (l_dbg) THEN
1212    OPEN (UNIT=22,file=TRIM(def_file)//'.test')
1213    DO i=1,nb_lines
1214      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
1215    ENDDO
1216    CLOSE(UNIT=22)
1217  ENDIF
1218!-
1219  IF (l_dbg) THEN
1220     WRITE(*,*) "nb_lines ",nb_lines,"nb_keys ",nb_keys
1221     WRITE(*,*) "fichier ",fichier(1:nb_lines)
1222     WRITE(*,*) "targetlist ",targetlist(1:nb_lines)
1223     WRITE(*,*) "fromfile ",fromfile(1:nb_lines)
1224     WRITE(*,*) "compline ",compline(1:nb_lines)
1225    WRITE(*,*) '<-getin_readdef'
1226  ENDIF
1227!---------------------------
1228END SUBROUTINE getin_readdef
1229!-
1230!===
1231!-
1232SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
1233!---------------------------------------------------------------------
1234!- This subroutine is going to decypher the line.
1235!- It essentialy checks how many items are included and
1236!- it they can be attached to a key.
1237!---------------------------------------------------------------------
1238  IMPLICIT NONE
1239!-
1240! ARGUMENTS
1241!-
1242  INTEGER :: current,nb_lastkey
1243  CHARACTER(LEN=*) :: key_str,NEW_str,last_key
1244!-
1245! LOCAL
1246!-
1247  INTEGER :: len_str,blk,nbve,starpos
1248  CHARACTER(LEN=100) :: tmp_str,new_key,mult
1249  CHARACTER(LEN=n_d_fmt) :: cnt
1250  CHARACTER(LEN=10) :: c_fmt
1251  LOGICAL :: l_dbg
1252!---------------------------------------------------------------------
1253  CALL ipsldbg (old_status=l_dbg)
1254!---------------------------------------------------------------------
1255  len_str = LEN_TRIM(NEW_str)
1256  blk = INDEX(NEW_str(1:len_str),' ')
1257  tmp_str = NEW_str(1:len_str)
1258!-
1259! If the key is a new file then we take it up. Else
1260! we save the line and go on.
1261!-
1262  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
1263    DO WHILE (blk > 0)
1264      IF (nbfiles+1 > max_files) THEN
1265        CALL ipslerr (3,'getin_decrypt', &
1266 &       'Too many files to include',' ',' ')
1267      ENDIF
1268!-----
1269      nbfiles = nbfiles+1
1270      filelist(nbfiles) = tmp_str(1:blk)
1271!-----
1272      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1273      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
1274    ENDDO
1275!---
1276    IF (nbfiles+1 > max_files) THEN
1277      CALL ipslerr (3,'getin_decrypt', &
1278 &     'Too many files to include',' ',' ')
1279    ENDIF
1280!---
1281    nbfiles =  nbfiles+1
1282    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
1283!---
1284    last_key = 'INCLUDEDEF'
1285    nb_lastkey = 1
1286  ELSE
1287!-
1288!-- We are working on a new line of input
1289!-
1290    IF (nb_lines+1 > i_txtsize) THEN
1291      CALL getin_alloctxt ()
1292    ENDIF
1293    nb_lines = nb_lines+1
1294!-
1295!-- First we solve the issue of conpressed information. Once
1296!-- this is done all line can be handled in the same way.
1297!-
1298    starpos = INDEX(NEW_str(1:len_str),'*')
1299    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
1300 &                    .AND.(tmp_str(1:1) /= "'") ) THEN
1301!-----
1302      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
1303        CALL ipslerr (3,'getin_decrypt', &
1304 &       'We can not have a compressed field of values', &
1305 &       'in a vector notation (TARGET__n).', &
1306 &       'The key at fault : '//TRIM(key_str))
1307      ENDIF
1308!-
1309!---- Read the multiplied
1310!-
1311      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
1312!---- Construct the new string and its parameters
1313      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
1314      len_str = LEN_TRIM(NEW_str)
1315      blk = INDEX(NEW_str(1:len_str),' ')
1316      IF (blk > 1) THEN
1317        CALL ipslerr (2,'getin_decrypt', &
1318 &       'This is a strange behavior','you could report',' ')
1319      ENDIF
1320      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
1321      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
1322!---
1323    ELSE
1324      compline(nb_lines) = -1
1325    ENDIF
1326!-
1327!-- If there is no space wthin the line then the target is a scalar
1328!-- or the element of a properly written vector.
1329!-- (ie of the type TARGET__00001)
1330!-
1331    IF (    (blk <= 1) &
1332 &      .OR.(tmp_str(1:1) == '"') &
1333 &      .OR.(tmp_str(1:1) == "'") ) THEN
1334!-
1335      IF (nb_lastkey == 0) THEN
1336!------ Save info of current keyword as a scalar
1337!------ if it is not a continuation
1338        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
1339        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
1340        nb_lastkey = 1
1341      ELSE
1342!------ We are continuing a vector so the keyword needs
1343!------ to get the underscores
1344        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
1345        targetlist(nb_lines) = &
1346 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1347        last_key = &
1348 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1349        nb_lastkey = nb_lastkey+1
1350      ENDIF
1351!-----
1352      fichier(nb_lines) = NEW_str(1:len_str)
1353      fromfile(nb_lines) = current
1354    ELSE
1355!-
1356!---- If there are blanks whithin the line then we are dealing
1357!---- with a vector and we need to split it in many entries
1358!---- with the TARGET__n notation.
1359!----
1360!---- Test if the targer is not already a vector target !
1361!-
1362      IF (INDEX(TRIM(key_str),'__') > 0) THEN
1363        CALL ipslerr (3,'getin_decrypt', &
1364 &       'We have found a mixed vector notation (TARGET__n).', &
1365 &       'The key at fault : '//TRIM(key_str),' ')
1366      ENDIF
1367!-
1368      nbve = nb_lastkey
1369      nbve = nbve+1
1370      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
1371!-
1372      DO WHILE (blk > 0)
1373!-
1374!------ Save the content of target__nbve
1375!-
1376        fichier(nb_lines) = tmp_str(1:blk)
1377        new_key = &
1378 &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1379        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
1380        fromfile(nb_lines) = current
1381!-
1382        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1383        blk = INDEX(TRIM(tmp_str),' ')
1384!-
1385        IF (nb_lines+1 > i_txtsize) THEN
1386          CALL getin_alloctxt ()
1387        ENDIF
1388        nb_lines = nb_lines+1
1389        nbve = nbve+1
1390        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
1391        compline(nb_lines)=compline(nb_lines-1)
1392!-
1393      ENDDO
1394!-
1395!---- Save the content of the last target
1396!-
1397      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
1398      new_key = &
1399 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1400      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
1401      fromfile(nb_lines) = current
1402!-
1403      last_key = &
1404 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1405      nb_lastkey = nbve
1406!-
1407    ENDIF
1408!-
1409  ENDIF
1410
1411  IF (l_dbg) THEN
1412     WRITE(*,*) "getin_decrypt ->",TRIM(NEW_str), " : "
1413     WRITE(*,*) "getin_decrypt ->", nb_lines,&
1414          & SIZE(fichier), &
1415          & SIZE(fromfile), &
1416          & SIZE(filelist)
1417     IF (nb_lines > 0) THEN
1418        WRITE(*,*) "getin_decrypt ->",TRIM(NEW_str), " : ", &
1419          & TRIM(fichier(nb_lines)), &
1420          & fromfile(nb_lines), &
1421          & TRIM(filelist(fromfile(nb_lines)))
1422        WRITE(*,*) "                compline : ",compline(nb_lines)
1423        WRITE(*,*) "                targetlist : ",TRIM(targetlist(nb_lines))
1424     ENDIF
1425     WRITE(*,*) "                last_key : ",last_key
1426  ENDIF
1427!---------------------------
1428END SUBROUTINE getin_decrypt
1429!-
1430!===
1431!-
1432SUBROUTINE getin_checkcohe ()
1433!---------------------------------------------------------------------
1434!- This subroutine checks for redundancies.
1435!---------------------------------------------------------------------
1436  IMPLICIT NONE
1437!-
1438  INTEGER :: line,n_k,k
1439!---------------------------------------------------------------------
1440  DO line=1,nb_lines-1
1441!-
1442    n_k = 0
1443    DO k=line+1,nb_lines
1444      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
1445        n_k = k
1446        EXIT
1447      ENDIF
1448    ENDDO
1449!---
1450!-- IF we have found it we have a problem to solve.
1451!---
1452    IF (n_k > 0) THEN
1453      WRITE(*,*) 'COUNT : ',n_k
1454      WRITE(*,*) &
1455 &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
1456      WRITE(*,*) &
1457 &  'getin_checkcohe : The following values were encoutered :'
1458      WRITE(*,*) &
1459 &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
1460      WRITE(*,*) &
1461 &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
1462      WRITE(*,*) &
1463 &  'getin_checkcohe : We will keep only the last value'
1464       CALL ipslerr (2,'getin_checkcohe','Found a problem on key ', &
1465 &                     TRIM(targetlist(line)), fichier(line)//" "//fichier(k))
1466      targetlist(line) = ' '
1467    ENDIF
1468  ENDDO
1469!-----------------------------
1470END SUBROUTINE getin_checkcohe
1471!-
1472!===
1473!-
1474SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
1475!---------------------------------------------------------------------
1476  IMPLICIT NONE
1477!-
1478  INTEGER :: unit,eof,nb_lastkey
1479  CHARACTER(LEN=100) :: dummy
1480  CHARACTER(LEN=100) :: out_string
1481  CHARACTER(LEN=1) :: first
1482!---------------------------------------------------------------------
1483  first="#"
1484  eof = 0
1485  out_string = "    "
1486!-
1487  DO WHILE (first == "#")
1488    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
1489    dummy = TRIM(ADJUSTL(dummy))
1490    first=dummy(1:1)
1491    IF (first == "#") THEN
1492      nb_lastkey = 0
1493    ENDIF
1494  ENDDO
1495  out_string=dummy
1496!-
1497  RETURN
1498!-
14999998 CONTINUE
1500  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
1501!-
15027778 CONTINUE
1503  eof = 1
1504!----------------------------
1505END SUBROUTINE getin_skipafew
1506!-
1507!===
1508!-
1509SUBROUTINE getin_allockeys ()
1510!---------------------------------------------------------------------
1511  IMPLICIT NONE
1512!-
1513  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
1514!-
1515  INTEGER :: ier
1516  CHARACTER(LEN=20) :: c_tmp
1517!---------------------------------------------------------------------
1518  IF (keymemsize == 0) THEN
1519!---
1520!-- Nothing exists in memory arrays and it is easy to do.
1521!---
1522    WRITE (UNIT=c_tmp,FMT=*) memslabs
1523    ALLOCATE(key_tab(memslabs),stat=ier)
1524    IF (ier /= 0) THEN
1525      CALL ipslerr (3,'getin_allockeys', &
1526 &     'Can not allocate key_tab', &
1527 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1528    ENDIF
1529    nb_keys = 0
1530    keymemsize = memslabs
1531    key_tab(:)%keycompress = -1
1532!---
1533  ELSE
1534!---
1535!-- There is something already in the memory,
1536!-- we need to transfer and reallocate.
1537!---
1538    WRITE (UNIT=c_tmp,FMT=*) keymemsize
1539    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
1540    IF (ier /= 0) THEN
1541      CALL ipslerr (3,'getin_allockeys', &
1542 &     'Can not allocate tmp_key_tab', &
1543 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1544    ENDIF
1545    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
1546    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
1547    DEALLOCATE(key_tab)
1548    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
1549    IF (ier /= 0) THEN
1550      CALL ipslerr (3,'getin_allockeys', &
1551 &     'Can not allocate key_tab', &
1552 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1553    ENDIF
1554    key_tab(:)%keycompress = -1
1555    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
1556    DEALLOCATE(tmp_key_tab)
1557    keymemsize = keymemsize+memslabs
1558  ENDIF
1559!-----------------------------
1560END SUBROUTINE getin_allockeys
1561!-
1562!===
1563!-
1564SUBROUTINE getin_allocmem (type,len_wanted)
1565!---------------------------------------------------------------------
1566!- Allocate the memory of the data base for all 4 types of memory
1567!- INTEGER / REAL / CHARACTER / LOGICAL
1568!---------------------------------------------------------------------
1569  IMPLICIT NONE
1570!-
1571  INTEGER :: type,len_wanted
1572!-
1573  INTEGER,ALLOCATABLE :: tmp_int(:)
1574  REAL,ALLOCATABLE :: tmp_real(:)
1575  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
1576  LOGICAL,ALLOCATABLE :: tmp_logic(:)
1577  INTEGER :: ier
1578  CHARACTER(LEN=20) :: c_tmp
1579!---------------------------------------------------------------------
1580  SELECT CASE (type)
1581  CASE(k_i)
1582    IF (i_memsize == 0) THEN
1583      ALLOCATE(i_mem(memslabs),stat=ier)
1584      IF (ier /= 0) THEN
1585        WRITE (UNIT=c_tmp,FMT=*) memslabs
1586        CALL ipslerr (3,'getin_allocmem', &
1587 &       'Unable to allocate db-memory', &
1588 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1589      ENDIF
1590      i_memsize=memslabs
1591    ELSE
1592      ALLOCATE(tmp_int(i_memsize),stat=ier)
1593      IF (ier /= 0) THEN
1594        WRITE (UNIT=c_tmp,FMT=*) i_memsize
1595        CALL ipslerr (3,'getin_allocmem', &
1596 &       'Unable to allocate tmp_int', &
1597 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1598      ENDIF
1599      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
1600      DEALLOCATE(i_mem)
1601      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
1602      IF (ier /= 0) THEN
1603        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
1604        CALL ipslerr (3,'getin_allocmem', &
1605 &       'Unable to re-allocate db-memory', &
1606 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1607      ENDIF
1608      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
1609      i_memsize = i_memsize+MAX(memslabs,len_wanted)
1610      DEALLOCATE(tmp_int)
1611    ENDIF
1612  CASE(k_r)
1613    IF (r_memsize == 0) THEN
1614      ALLOCATE(r_mem(memslabs),stat=ier)
1615      IF (ier /= 0) THEN
1616        WRITE (UNIT=c_tmp,FMT=*) memslabs
1617        CALL ipslerr (3,'getin_allocmem', &
1618 &       'Unable to allocate db-memory', &
1619 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1620      ENDIF
1621      r_memsize =  memslabs
1622    ELSE
1623      ALLOCATE(tmp_real(r_memsize),stat=ier)
1624      IF (ier /= 0) THEN
1625        WRITE (UNIT=c_tmp,FMT=*) r_memsize
1626        CALL ipslerr (3,'getin_allocmem', &
1627 &       'Unable to allocate tmp_real', &
1628 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1629      ENDIF
1630      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
1631      DEALLOCATE(r_mem)
1632      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
1633      IF (ier /= 0) THEN
1634        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
1635        CALL ipslerr (3,'getin_allocmem', &
1636 &       'Unable to re-allocate db-memory', &
1637 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1638      ENDIF
1639      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
1640      r_memsize = r_memsize+MAX(memslabs,len_wanted)
1641      DEALLOCATE(tmp_real)
1642    ENDIF
1643  CASE(k_c)
1644    IF (c_memsize == 0) THEN
1645      ALLOCATE(c_mem(memslabs),stat=ier)
1646      IF (ier /= 0) THEN
1647        WRITE (UNIT=c_tmp,FMT=*) memslabs
1648        CALL ipslerr (3,'getin_allocmem', &
1649 &       'Unable to allocate db-memory', &
1650 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1651      ENDIF
1652      c_memsize = memslabs
1653    ELSE
1654      ALLOCATE(tmp_char(c_memsize),stat=ier)
1655      IF (ier /= 0) THEN
1656        WRITE (UNIT=c_tmp,FMT=*) c_memsize
1657        CALL ipslerr (3,'getin_allocmem', &
1658 &       'Unable to allocate tmp_char', &
1659 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1660      ENDIF
1661      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
1662      DEALLOCATE(c_mem)
1663      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
1664      IF (ier /= 0) THEN
1665        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
1666        CALL ipslerr (3,'getin_allocmem', &
1667 &       'Unable to re-allocate db-memory', &
1668 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1669      ENDIF
1670      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
1671      c_memsize = c_memsize+MAX(memslabs,len_wanted)
1672      DEALLOCATE(tmp_char)
1673    ENDIF
1674  CASE(k_l)
1675    IF (l_memsize == 0) THEN
1676      ALLOCATE(l_mem(memslabs),stat=ier)
1677      IF (ier /= 0) THEN
1678        WRITE (UNIT=c_tmp,FMT=*) memslabs
1679        CALL ipslerr (3,'getin_allocmem', &
1680 &       'Unable to allocate db-memory', &
1681 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1682      ENDIF
1683      l_memsize = memslabs
1684    ELSE
1685      ALLOCATE(tmp_logic(l_memsize),stat=ier)
1686      IF (ier /= 0) THEN
1687        WRITE (UNIT=c_tmp,FMT=*) l_memsize
1688        CALL ipslerr (3,'getin_allocmem', &
1689 &       'Unable to allocate tmp_logic', &
1690 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1691      ENDIF
1692      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
1693      DEALLOCATE(l_mem)
1694      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
1695      IF (ier /= 0) THEN
1696        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
1697        CALL ipslerr (3,'getin_allocmem', &
1698 &       'Unable to re-allocate db-memory', &
1699 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1700      ENDIF
1701      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
1702      l_memsize = l_memsize+MAX(memslabs,len_wanted)
1703      DEALLOCATE(tmp_logic)
1704    ENDIF
1705  CASE DEFAULT
1706    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
1707  END SELECT
1708!----------------------------
1709END SUBROUTINE getin_allocmem
1710!-
1711!===
1712!-
1713SUBROUTINE getin_alloctxt ()
1714!---------------------------------------------------------------------
1715  IMPLICIT NONE
1716!-
1717  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
1718  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
1719  INTEGER,ALLOCATABLE :: tmp_int(:)
1720!-
1721  INTEGER :: ier
1722  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
1723!---------------------------------------------------------------------
1724  IF (i_txtsize == 0) THEN
1725!---
1726!-- Nothing exists in memory arrays and it is easy to do.
1727!---
1728    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
1729    ALLOCATE(fichier(i_txtslab),stat=ier)
1730    IF (ier /= 0) THEN
1731      CALL ipslerr (3,'getin_alloctxt', &
1732 &     'Can not allocate fichier', &
1733 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1734    ENDIF
1735!---
1736    ALLOCATE(targetlist(i_txtslab),stat=ier)
1737    IF (ier /= 0) THEN
1738      CALL ipslerr (3,'getin_alloctxt', &
1739 &     'Can not allocate targetlist', &
1740 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1741    ENDIF
1742!---
1743    ALLOCATE(fromfile(i_txtslab),stat=ier)
1744    IF (ier /= 0) THEN
1745      CALL ipslerr (3,'getin_alloctxt', &
1746 &     'Can not allocate fromfile', &
1747 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1748    ENDIF
1749!---
1750    ALLOCATE(compline(i_txtslab),stat=ier)
1751    IF (ier /= 0) THEN
1752      CALL ipslerr (3,'getin_alloctxt', &
1753 &     'Can not allocate compline', &
1754 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1755    ENDIF
1756!---
1757    nb_lines = 0
1758    i_txtsize = i_txtslab
1759  ELSE
1760!---
1761!-- There is something already in the memory,
1762!-- we need to transfer and reallocate.
1763!---
1764    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
1765    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
1766    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
1767    IF (ier /= 0) THEN
1768      CALL ipslerr (3,'getin_alloctxt', &
1769 &     'Can not allocate tmp_fic', &
1770 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1771    ENDIF
1772    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
1773    DEALLOCATE(fichier)
1774    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
1775    IF (ier /= 0) THEN
1776      CALL ipslerr (3,'getin_alloctxt', &
1777 &     'Can not allocate fichier', &
1778 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1779    ENDIF
1780    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
1781    DEALLOCATE(tmp_fic)
1782!---
1783    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
1784    IF (ier /= 0) THEN
1785      CALL ipslerr (3,'getin_alloctxt', &
1786 &     'Can not allocate tmp_tgl', &
1787 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1788    ENDIF
1789    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
1790    DEALLOCATE(targetlist)
1791    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
1792    IF (ier /= 0) THEN
1793      CALL ipslerr (3,'getin_alloctxt', &
1794 &     'Can not allocate targetlist', &
1795 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1796    ENDIF
1797    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
1798    DEALLOCATE(tmp_tgl)
1799!---
1800    ALLOCATE(tmp_int(i_txtsize),stat=ier)
1801    IF (ier /= 0) THEN
1802      CALL ipslerr (3,'getin_alloctxt', &
1803 &     'Can not allocate tmp_int', &
1804 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1805    ENDIF
1806    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
1807    DEALLOCATE(fromfile)
1808    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
1809    IF (ier /= 0) THEN
1810      CALL ipslerr (3,'getin_alloctxt', &
1811 &     'Can not allocate fromfile', &
1812 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1813    ENDIF
1814    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
1815!---
1816    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
1817    DEALLOCATE(compline)
1818    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
1819    IF (ier /= 0) THEN
1820      CALL ipslerr (3,'getin_alloctxt', &
1821 &     'Can not allocate compline', &
1822 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1823    ENDIF
1824    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
1825    DEALLOCATE(tmp_int)
1826!---
1827    i_txtsize = i_txtsize+i_txtslab
1828  ENDIF
1829!----------------------------
1830END SUBROUTINE getin_alloctxt
1831!-
1832!===
1833!-
1834SUBROUTINE getin_dump (fileprefix)
1835!---------------------------------------------------------------------
1836  IMPLICIT NONE
1837!-
1838  CHARACTER(*),OPTIONAL :: fileprefix
1839!-
1840  CHARACTER(LEN=80) :: usedfileprefix
1841  INTEGER :: ikey,if,iff,iv
1842  INTEGER :: ios
1843  CHARACTER(LEN=20) :: c_tmp
1844  CHARACTER(LEN=100) :: tmp_str,used_filename
1845  INTEGER :: io_err
1846  LOGICAL :: l_dbg
1847!---------------------------------------------------------------------
1848  CALL ipsldbg (old_status=l_dbg)
1849!---------------------------------------------------------------------
1850  IF (PRESENT(fileprefix)) THEN
1851    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
1852  ELSE
1853    usedfileprefix = "used"
1854  ENDIF
1855!-
1856  DO if=1,nbfiles
1857!---
1858    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
1859    IF (l_dbg) THEN
1860      WRITE(*,*) &
1861 &      'getin_dump : opens file : ',TRIM(used_filename),' if = ',if
1862      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
1863    ENDIF
1864    OPEN (UNIT=22,FILE=used_filename,iostat=io_err)
1865    IF (io_err /= 0) THEN
1866       CALL ipslerr (3,'getin_dump', &
1867            &   'Could not open file :',TRIM(used_filename), &
1868            &   '')
1869    ENDIF
1870!---
1871!-- If this is the first file we need to add the list
1872!-- of file which belong to it
1873    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
1874      WRITE(22,*) '# '
1875      WRITE(22,*) '# This file is linked to the following files :'
1876      WRITE(22,*) '# '
1877      DO iff=2,nbfiles
1878        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
1879      ENDDO
1880      WRITE(22,*) '# '
1881      IF (l_dbg) THEN
1882         WRITE(*,*) '# '
1883         WRITE(*,*) '# This file is linked to the following files :'
1884         WRITE(*,*) '# '
1885         DO iff=2,nbfiles
1886            WRITE(*,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
1887         ENDDO
1888         WRITE(*,*) '# '
1889      ENDIF
1890    ENDIF
1891!---
1892    DO ikey=1,nb_keys
1893!-----
1894!---- Is this key from this file ?
1895      IF (key_tab(ikey)%keyfromfile == if) THEN
1896!-------
1897!------ Write some comments
1898        WRITE(22,*) '#'
1899        SELECT CASE (key_tab(ikey)%keystatus)
1900        CASE(nondefault)
1901          WRITE(22,*) '# Values of ', &
1902 &          TRIM(key_tab(ikey)%keystr),' comes from ',TRIM(def_file)
1903        CASE(default)
1904          WRITE(22,*) '# Values of ', &
1905 &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
1906        CASE(vectornondefault)
1907          WRITE(22,*) '# Values of ', &
1908 &          TRIM(key_tab(ikey)%keystr), &
1909 &          ' are a mix of ',TRIM(def_file),' and defaults.'
1910        CASE DEFAULT
1911          WRITE(22,*) '# Dont know from where the value of ', &
1912 &          TRIM(key_tab(ikey)%keystr),' comes.'
1913        END SELECT
1914        WRITE(22,*) '#'
1915        !-
1916        IF (l_dbg) THEN
1917           WRITE(*,*) '#'
1918           WRITE(*,*) '# Status of key ', ikey, ' : ',&
1919 &          TRIM(key_tab(ikey)%keystr),key_tab(ikey)%keystatus
1920        ENDIF
1921!-------
1922!------ Write the values
1923        SELECT CASE (key_tab(ikey)%keytype)
1924        CASE(k_i)
1925          IF (key_tab(ikey)%keymemlen == 1) THEN
1926            IF (key_tab(ikey)%keycompress < 0) THEN
1927              WRITE(22,*) &
1928 &              TRIM(key_tab(ikey)%keystr), &
1929 &              ' = ',i_mem(key_tab(ikey)%keymemstart)
1930            ELSE
1931              WRITE(22,*) &
1932 &              TRIM(key_tab(ikey)%keystr), &
1933 &              ' = ',key_tab(ikey)%keycompress, &
1934 &              ' * ',i_mem(key_tab(ikey)%keymemstart)
1935            ENDIF
1936          ELSE
1937            DO iv=0,key_tab(ikey)%keymemlen-1
1938              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1939              WRITE(22,*) &
1940 &              TRIM(key_tab(ikey)%keystr), &
1941 &              '__',TRIM(ADJUSTL(c_tmp)), &
1942 &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
1943            ENDDO
1944          ENDIF
1945        CASE(k_r)
1946          IF (key_tab(ikey)%keymemlen == 1) THEN
1947            IF (key_tab(ikey)%keycompress < 0) THEN
1948              WRITE(22,*) &
1949 &              TRIM(key_tab(ikey)%keystr), &
1950 &              ' = ',r_mem(key_tab(ikey)%keymemstart)
1951            ELSE
1952              WRITE(22,*) &
1953 &              TRIM(key_tab(ikey)%keystr), &
1954 &              ' = ',key_tab(ikey)%keycompress, &
1955                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
1956            ENDIF
1957          ELSE
1958            DO iv=0,key_tab(ikey)%keymemlen-1
1959              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1960              WRITE(22,*) &
1961 &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
1962 &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
1963            ENDDO
1964          ENDIF
1965        CASE(k_c)
1966          IF (key_tab(ikey)%keymemlen == 1) THEN
1967            tmp_str = c_mem(key_tab(ikey)%keymemstart)
1968            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
1969 &              ' = ',TRIM(tmp_str)
1970          ELSE
1971            DO iv=0,key_tab(ikey)%keymemlen-1
1972              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1973              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
1974              WRITE(22,*) &
1975 &              TRIM(key_tab(ikey)%keystr), &
1976 &              '__',TRIM(ADJUSTL(c_tmp)), &
1977 &              ' = ',TRIM(tmp_str)
1978            ENDDO
1979          ENDIF
1980        CASE(k_l)
1981          IF (key_tab(ikey)%keymemlen == 1) THEN
1982            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
1983              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
1984            ELSE
1985              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
1986            ENDIF
1987          ELSE
1988            DO iv=0,key_tab(ikey)%keymemlen-1
1989              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1990              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
1991                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
1992 &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
1993              ELSE
1994                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
1995 &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
1996              ENDIF
1997            ENDDO
1998          ENDIF
1999        CASE DEFAULT
2000          CALL ipslerr (3,'getin_dump', &
2001 &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
2002 &         ' ',' ')
2003        END SELECT
2004      ENDIF
2005    ENDDO
2006!-
2007    CLOSE(UNIT=22)
2008!-
2009  ENDDO
2010!------------------------
2011END SUBROUTINE getin_dump
2012!===
2013SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
2014!---------------------------------------------------------------------
2015!- Returns the type of the argument (mutually exclusive)
2016!---------------------------------------------------------------------
2017  IMPLICIT NONE
2018!-
2019  INTEGER,INTENT(OUT) :: k_typ
2020  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
2021  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
2022  REAL,DIMENSION(:),OPTIONAL             :: r_v
2023  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
2024  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
2025!---------------------------------------------------------------------
2026  k_typ = 0
2027  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
2028 &    /= 1) THEN
2029    CALL ipslerr (3,'get_qtyp', &
2030 &   'Invalid number of optional arguments','(/= 1)',' ')
2031  ENDIF
2032!-
2033  IF     (PRESENT(i_v)) THEN
2034    k_typ = k_i
2035    c_vtyp = 'INTEGER'
2036  ELSEIF (PRESENT(r_v)) THEN
2037    k_typ = k_r
2038    c_vtyp = 'REAL'
2039  ELSEIF (PRESENT(c_v)) THEN
2040    k_typ = k_c
2041    c_vtyp = 'CHARACTER'
2042  ELSEIF (PRESENT(l_v)) THEN
2043    k_typ = k_l
2044    c_vtyp = 'LOGICAL'
2045  ENDIF
2046!----------------------
2047END SUBROUTINE get_qtyp
2048!===
2049SUBROUTINE get_findkey (i_tab,c_key,pos)
2050!---------------------------------------------------------------------
2051!- This subroutine looks for a key in a table
2052!---------------------------------------------------------------------
2053!- INPUT
2054!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
2055!-            2 -> search in targetlist(1:nb_lines)
2056!-   c_key  : Name of the key we are looking for
2057!- OUTPUT
2058!-   pos    : -1 if key not found, else value in the table
2059!---------------------------------------------------------------------
2060  IMPLICIT NONE
2061!-
2062  INTEGER,INTENT(in) :: i_tab
2063  CHARACTER(LEN=*),INTENT(in) :: c_key
2064  INTEGER,INTENT(out) :: pos
2065!-
2066  INTEGER :: ikey_max,ikey
2067  CHARACTER(LEN=l_n) :: c_q_key
2068!---------------------------------------------------------------------
2069  pos = -1
2070  IF     (i_tab == 1) THEN
2071    ikey_max = nb_keys
2072  ELSEIF (i_tab == 2) THEN
2073    ikey_max = nb_lines
2074  ELSE
2075    ikey_max = 0
2076  ENDIF
2077  IF ( ikey_max > 0 ) THEN
2078    DO ikey=1,ikey_max
2079      IF (i_tab == 1) THEN
2080        c_q_key = key_tab(ikey)%keystr
2081      ELSE
2082        c_q_key = targetlist(ikey)
2083      ENDIF
2084      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
2085        pos = ikey
2086        EXIT
2087      ENDIF
2088    ENDDO
2089  ENDIF
2090!-------------------------
2091END SUBROUTINE get_findkey
2092!===
2093!------------------
2094END MODULE getincom
Note: See TracBrowser for help on using the repository browser.