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

Last change on this file since 386 was 386, checked in by bellier, 16 years ago

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