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

Last change on this file since 963 was 963, checked in by bellier, 15 years ago

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