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

Last change on this file since 11 was 11, checked in by bellier, 17 years ago

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