Context Navigation

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

Last change on this file since 1314 was 1314, checked in by mmaipsl, 13 years ago

In my previous (1313) I forget to mention D.Solyga and I have corrected a bug in

getincom, from rev 11 :
nb_to_ret wasn't correctly assigned in get_fil then we add the correct argument.

In this commit, I have corrected a problem for vector partialy defined with getin and

the use of link files with INCLUDEDEF pragma (the dump report was wrong).

Property svn:keywords set to Id

File size: 63.2 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: