Context Navigation

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

Last change on this file since 1315 was 1315, checked in by mmaipsl, 14 years ago
Correct another bug come from rev 11 : if real compressed vectors were used, the line 841 had disappeared. This doesn't seem to change the result.
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	r_val(it) = r_cmpval
842	ENDIF
843	found(it) = .TRUE.
844	ENDIF
845	ENDDO
846	ENDIF
847	ENDIF
848	!-
849	! Now we set the status for what we found
850	IF (def_beha) THEN
851	status = default
852	CALL ipslerr (1,'USING DEFAULT BEHAVIOUR FOR', &
853	& TRIM(targetname),' ',' ')
854	WRITE(,) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(targetname)
855	ELSE
856	status_cnt = 0
857	DO it=1,nb_to_ret
858	IF (.NOT.found(it)) THEN
859	status_cnt = status_cnt+1
860	IF (status_cnt <= max_msgs) THEN
861	WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
862	& ADVANCE='NO') TRIM(targetname)
863	IF (nb_to_ret > 1) THEN
864	WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
865	WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
866	ENDIF
867	SELECT CASE (k_typ)
868	CASE(k_i)
869	WRITE (UNIT=,FMT=) "=",i_val(it)
870	CASE(k_r)
871	WRITE (UNIT=,FMT=) "=",r_val(it)
872	CASE(k_c)
873	WRITE (UNIT=,FMT=) "=",c_val(it)
874	CASE(k_l)
875	WRITE (UNIT=,FMT=) "=",l_val(it)
876	END SELECT
877	ELSE IF (status_cnt == max_msgs+1) THEN
878	WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
879	ENDIF
880	ENDIF
881	ENDDO
882	!---
883	IF (status_cnt == 0) THEN
884	status = nondefault
885	ELSE IF (status_cnt == nb_to_ret) THEN
886	status = default
887	ELSE
888	status = vectornondefault
889	ENDIF
890	ENDIF
891	! Deallocate the memory
892	DEALLOCATE(found)
893	!---------------------
894	END SUBROUTINE get_fil
895	!===
896	SUBROUTINE get_rdb (pos,size_of_in,targetname,i_val,r_val,c_val,l_val)
897	!---------------------------------------------------------------------
898	!- Read the required variable in the database
899	!---------------------------------------------------------------------
900	IMPLICIT NONE
901	!-
902	INTEGER :: pos,size_of_in
903	CHARACTER(LEN=*) :: targetname
904	INTEGER,DIMENSION(:),OPTIONAL :: i_val
905	REAL,DIMENSION(:),OPTIONAL :: r_val
906	LOGICAL,DIMENSION(:),OPTIONAL :: l_val
907	CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
908	!-
909	INTEGER :: k_typ,k_beg,k_end
910	CHARACTER(LEN=9) :: c_vtyp
911	!---------------------------------------------------------------------
912	!-
913	! Get the type of the argument
914	CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
915	IF ( (k_typ /= k_i).AND.(k_typ /= k_r) &
916	& .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
917	CALL ipslerr (3,'get_rdb', &
918	& 'Internal error','Unknown type of data',' ')
919	ENDIF
920	!-
921	IF (key_tab(pos)%keytype /= k_typ) THEN
922	CALL ipslerr (3,'get_rdb', &
923	& 'Wrong data type for keyword '//TRIM(targetname), &
924	& '(NOT '//TRIM(c_vtyp)//')',' ')
925	ENDIF
926	!-
927	IF (key_tab(pos)%keycompress > 0) THEN
928	IF ( (key_tab(pos)%keycompress /= size_of_in) &
929	& .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
930	CALL ipslerr (3,'get_rdb', &
931	& 'Wrong compression length','for keyword '//TRIM(targetname),' ')
932	ELSE
933	SELECT CASE (k_typ)
934	CASE(k_i)
935	i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
936	CASE(k_r)
937	r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
938	END SELECT
939	ENDIF
940	ELSE
941	IF (key_tab(pos)%keymemlen /= size_of_in) THEN
942	CALL ipslerr (3,'get_rdb', &
943	& 'Wrong array length','for keyword '//TRIM(targetname),' ')
944	ELSE
945	k_beg = key_tab(pos)%keymemstart
946	k_end = k_beg+key_tab(pos)%keymemlen-1
947	SELECT CASE (k_typ)
948	CASE(k_i)
949	i_val(1:size_of_in) = i_mem(k_beg:k_end)
950	CASE(k_r)
951	r_val(1:size_of_in) = r_mem(k_beg:k_end)
952	CASE(k_c)
953	c_val(1:size_of_in) = c_mem(k_beg:k_end)
954	CASE(k_l)
955	l_val(1:size_of_in) = l_mem(k_beg:k_end)
956	END SELECT
957	ENDIF
958	ENDIF
959	!---------------------
960	END SUBROUTINE get_rdb
961	!===
962	SUBROUTINE get_wdb &
963	& (targetname,status,fileorig,size_of_in, &
964	& i_val,r_val,c_val,l_val)
965	!---------------------------------------------------------------------
966	!- Write data into the data base
967	!---------------------------------------------------------------------
968	IMPLICIT NONE
969	!-
970	CHARACTER(LEN=*) :: targetname
971	INTEGER :: status,fileorig,size_of_in
972	INTEGER,DIMENSION(:),OPTIONAL :: i_val
973	REAL,DIMENSION(:),OPTIONAL :: r_val
974	LOGICAL,DIMENSION(:),OPTIONAL :: l_val
975	CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
976	!-
977	INTEGER :: k_typ
978	CHARACTER(LEN=9) :: c_vtyp
979	INTEGER :: k_mempos,k_memsize,k_beg,k_end
980	LOGICAL :: l_cmp
981	LOGICAL :: l_dbg
982	!---------------------------------------------------------------------
983	CALL ipsldbg (old_status=l_dbg)
984	!---------------------------------------------------------------------
985	!-
986	! Get the type of the argument
987	CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
988	IF ( (k_typ /= k_i).AND.(k_typ /= k_r) &
989	& .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
990	CALL ipslerr (3,'get_wdb', &
991	& 'Internal error','Unknown type of data',' ')
992	ENDIF
993	!-
994	! First check if we have sufficiant space for the new key
995	IF (nb_keys+1 > keymemsize) THEN
996	CALL getin_allockeys ()
997	ENDIF
998	!-
999	SELECT CASE (k_typ)
1000	CASE(k_i)
1001	k_mempos = i_mempos; k_memsize = i_memsize;
1002	l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
1003	& .AND.(size_of_in > compress_lim)
1004	CASE(k_r)
1005	k_mempos = r_mempos; k_memsize = r_memsize;
1006	l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
1007	& .AND.(size_of_in > compress_lim)
1008	CASE(k_c)
1009	k_mempos = c_mempos; k_memsize = c_memsize;
1010	l_cmp = .FALSE.
1011	CASE(k_l)
1012	k_mempos = l_mempos; k_memsize = l_memsize;
1013	l_cmp = .FALSE.
1014	END SELECT
1015	!-
1016	! Fill out the items of the data base
1017	nb_keys = nb_keys+1
1018	key_tab(nb_keys)%keystr = targetname(1:MIN(LEN_TRIM(targetname),l_n))
1019	key_tab(nb_keys)%keystatus = status
1020	key_tab(nb_keys)%keytype = k_typ
1021	key_tab(nb_keys)%keyfromfile = fileorig
1022	key_tab(nb_keys)%keymemstart = k_mempos+1
1023	IF (l_cmp) THEN
1024	key_tab(nb_keys)%keycompress = size_of_in
1025	key_tab(nb_keys)%keymemlen = 1
1026	ELSE
1027	key_tab(nb_keys)%keycompress = -1
1028	key_tab(nb_keys)%keymemlen = size_of_in
1029	ENDIF
1030	IF (l_dbg) THEN
1031	WRITE(,) &
1032	& "get_wdb : nb_keys ",nb_keys," key_tab keystr ",key_tab(nb_keys)%keystr,&
1033	& ",keystatus ",key_tab(nb_keys)%keystatus,&
1034	& ",keytype ",key_tab(nb_keys)%keytype,&
1035	& ",keycompress ",key_tab(nb_keys)%keycompress,&
1036	& ",keyfromfile ",key_tab(nb_keys)%keyfromfile,&
1037	& ",keymemstart ",key_tab(nb_keys)%keymemstart
1038	ENDIF
1039
1040	!-
1041	! Before writing the actual size lets see if we have the space
1042	IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
1043	& > k_memsize) THEN
1044	CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
1045	ENDIF
1046	!-
1047	k_beg = key_tab(nb_keys)%keymemstart
1048	k_end = k_beg+key_tab(nb_keys)%keymemlen-1
1049	SELECT CASE (k_typ)
1050	CASE(k_i)
1051	i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
1052	i_mempos = k_end
1053	CASE(k_r)
1054	r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
1055	r_mempos = k_end
1056	CASE(k_c)
1057	c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
1058	c_mempos = k_end
1059	CASE(k_l)
1060	l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
1061	l_mempos = k_end
1062	END SELECT
1063	!---------------------
1064	END SUBROUTINE get_wdb
1065	!-
1066	!===
1067	!-
1068	SUBROUTINE getin_read
1069	!---------------------------------------------------------------------
1070	IMPLICIT NONE
1071	!-
1072	INTEGER,SAVE :: current
1073	!---------------------------------------------------------------------
1074	IF (allread == 0) THEN
1075	!-- Allocate a first set of memory.
1076	CALL getin_alloctxt ()
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) = TRIM(def_file)
1085	current = 1
1086	!--
1087	DO WHILE (current <= nbfiles)
1088	CALL getin_readdef (current)
1089	current = current+1
1090	ENDDO
1091	allread = 1
1092	CALL getin_checkcohe ()
1093	ENDIF
1094	!------------------------
1095	END SUBROUTINE getin_read
1096	!-
1097	!===
1098	!-
1099	SUBROUTINE getin_readdef(current)
1100	!---------------------------------------------------------------------
1101	!- This subroutine will read the files and only keep the
1102	!- the relevant information. The information is kept as it
1103	!- found in the file. The data will be analysed later.
1104	!---------------------------------------------------------------------
1105	IMPLICIT NONE
1106	!-
1107	INTEGER :: current
1108	!-
1109	CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
1110	CHARACTER(LEN=n_d_fmt) :: cnt
1111	CHARACTER(LEN=10) :: c_fmt
1112	INTEGER :: nb_lastkey
1113	!-
1114	INTEGER :: eof,ptn,len_str,i,it,iund,io_err
1115	LOGICAL :: l_dbg
1116	!---------------------------------------------------------------------
1117	CALL ipsldbg (old_status=l_dbg)
1118	!---------------------------------------------------------------------
1119	eof = 0
1120	ptn = 1
1121	nb_lastkey = 0
1122	!-
1123	IF (l_dbg) THEN
1124	WRITE(,) 'getin_readdef : Open file ',TRIM(filelist(current))
1125	ENDIF
1126	!-
1127	OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
1128	IF (io_err /= 0) THEN
1129	CALL ipslerr (2,'getin_readdef', &
1130	& 'Could not open file '//TRIM(filelist(current)),' ',' ')
1131	RETURN
1132	ENDIF
1133	!-
1134	DO WHILE (eof /= 1)
1135	!---
1136	CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
1137	len_str = LEN_TRIM(READ_str)
1138	ptn = INDEX(READ_str,'=')
1139	!---
1140	IF (ptn > 0) THEN
1141	!---- Get the target
1142	key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
1143	!---- Make sure that a vector keyword has the right length
1144	iund = INDEX(key_str,'__')
1145	IF (iund > 0) THEN
1146	WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
1147	& LEN_TRIM(key_str)-iund-1
1148	READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
1149	& FMT=c_fmt,IOSTAT=io_err) it
1150	IF ( (io_err == 0).AND.(it > 0) ) THEN
1151	WRITE(UNIT=cnt,FMT=c_i_fmt) it
1152	key_str = key_str(1:iund+1)//cnt
1153	ELSE
1154	CALL ipslerr (3,'getin_readdef', &
1155	& 'A very strange key has just been found :', &
1156	& TRIM(key_str),' ')
1157	ENDIF
1158	ENDIF
1159	!---- Prepare the content
1160	NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
1161	CALL nocomma (NEW_str)
1162	CALL cmpblank (NEW_str)
1163	NEW_str = TRIM(ADJUSTL(NEW_str))
1164	IF (l_dbg) THEN
1165	WRITE(,) &
1166	& '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
1167	ENDIF
1168	!---- Decypher the content of NEW_str
1169	!-
1170	!---- This has to be a new key word, thus :
1171	nb_lastkey = 0
1172	!----
1173	CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
1174	!----
1175	ELSE IF (len_str > 0) THEN
1176	!---- Prepare the key if we have an old one to which
1177	!---- we will add the line just read
1178	IF (nb_lastkey > 0) THEN
1179	iund = INDEX(last_key,'__')
1180	IF (iund > 0) THEN
1181	!-------- We only continue a keyword, thus it is easy
1182	key_str = last_key(1:iund-1)
1183	ELSE
1184	IF (nb_lastkey /= 1) THEN
1185	CALL ipslerr (3,'getin_readdef', &
1186	& 'We can not have a scalar keyword', &
1187	& 'and a vector content',' ')
1188	ENDIF
1189	!-------- The last keyword needs to be transformed into a vector.
1190	WRITE(UNIT=cnt,FMT=c_i_fmt) 1
1191	targetlist(nb_lines) = &
1192	& last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
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 (l_dbg) THEN
1203	WRITE(,) 'getin_readdef : Have found an emtpy line '
1204	ENDIF
1205	ENDIF
1206	ENDDO
1207	!-
1208	CLOSE(UNIT=22)
1209	!-
1210	IF (l_dbg) THEN
1211	OPEN (UNIT=22,file=TRIM(def_file)//'.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	!-
1218	IF (l_dbg) THEN
1219	WRITE(,) "nb_lines ",nb_lines,"nb_keys ",nb_keys
1220	WRITE(,) "fichier ",fichier(1:nb_lines)
1221	WRITE(,) "targetlist ",targetlist(1:nb_lines)
1222	WRITE(,) "fromfile ",fromfile(1:nb_lines)
1223	WRITE(,) "compline ",compline(1:nb_lines)
1224	WRITE(,) '<-getin_readdef'
1225	ENDIF
1226	!---------------------------
1227	END SUBROUTINE getin_readdef
1228	!-
1229	!===
1230	!-
1231	SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
1232	!---------------------------------------------------------------------
1233	!- This subroutine is going to decypher the line.
1234	!- It essentialy checks how many items are included and
1235	!- it they can be attached to a key.
1236	!---------------------------------------------------------------------
1237	IMPLICIT NONE
1238	!-
1239	! ARGUMENTS
1240	!-
1241	INTEGER :: current,nb_lastkey
1242	CHARACTER(LEN=*) :: key_str,NEW_str,last_key
1243	!-
1244	! LOCAL
1245	!-
1246	INTEGER :: len_str,blk,nbve,starpos
1247	CHARACTER(LEN=100) :: tmp_str,new_key,mult
1248	CHARACTER(LEN=n_d_fmt) :: cnt
1249	CHARACTER(LEN=10) :: c_fmt
1250	LOGICAL :: l_dbg
1251	!---------------------------------------------------------------------
1252	CALL ipsldbg (old_status=l_dbg)
1253	!---------------------------------------------------------------------
1254	len_str = LEN_TRIM(NEW_str)
1255	blk = INDEX(NEW_str(1:len_str),' ')
1256	tmp_str = NEW_str(1:len_str)
1257	!-
1258	! If the key is a new file then we take it up. Else
1259	! we save the line and go on.
1260	!-
1261	IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
1262	DO WHILE (blk > 0)
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) = tmp_str(1:blk)
1270	!-----
1271	tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1272	blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
1273	ENDDO
1274	!---
1275	IF (nbfiles+1 > max_files) THEN
1276	CALL ipslerr (3,'getin_decrypt', &
1277	& 'Too many files to include',' ',' ')
1278	ENDIF
1279	!---
1280	nbfiles = nbfiles+1
1281	filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
1282	!---
1283	last_key = 'INCLUDEDEF'
1284	nb_lastkey = 1
1285	ELSE
1286	!-
1287	!-- We are working on a new line of input
1288	!-
1289	IF (nb_lines+1 > i_txtsize) THEN
1290	CALL getin_alloctxt ()
1291	ENDIF
1292	nb_lines = nb_lines+1
1293	!-
1294	!-- First we solve the issue of conpressed information. Once
1295	!-- this is done all line can be handled in the same way.
1296	!-
1297	starpos = INDEX(NEW_str(1:len_str),'*')
1298	IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
1299	& .AND.(tmp_str(1:1) /= "'") ) THEN
1300	!-----
1301	IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
1302	CALL ipslerr (3,'getin_decrypt', &
1303	& 'We can not have a compressed field of values', &
1304	& 'in a vector notation (TARGET__n).', &
1305	& 'The key at fault : '//TRIM(key_str))
1306	ENDIF
1307	!-
1308	!---- Read the multiplied
1309	!-
1310	mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
1311	!---- Construct the new string and its parameters
1312	NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
1313	len_str = LEN_TRIM(NEW_str)
1314	blk = INDEX(NEW_str(1:len_str),' ')
1315	IF (blk > 1) THEN
1316	CALL ipslerr (2,'getin_decrypt', &
1317	& 'This is a strange behavior','you could report',' ')
1318	ENDIF
1319	WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
1320	READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
1321	!---
1322	ELSE
1323	compline(nb_lines) = -1
1324	ENDIF
1325	!-
1326	!-- If there is no space wthin the line then the target is a scalar
1327	!-- or the element of a properly written vector.
1328	!-- (ie of the type TARGET__00001)
1329	!-
1330	IF ( (blk <= 1) &
1331	& .OR.(tmp_str(1:1) == '"') &
1332	& .OR.(tmp_str(1:1) == "'") ) THEN
1333	!-
1334	IF (nb_lastkey == 0) THEN
1335	!------ Save info of current keyword as a scalar
1336	!------ if it is not a continuation
1337	targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
1338	last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
1339	nb_lastkey = 1
1340	ELSE
1341	!------ We are continuing a vector so the keyword needs
1342	!------ to get the underscores
1343	WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
1344	targetlist(nb_lines) = &
1345	& key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1346	last_key = &
1347	& key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1348	nb_lastkey = nb_lastkey+1
1349	ENDIF
1350	!-----
1351	fichier(nb_lines) = NEW_str(1:len_str)
1352	fromfile(nb_lines) = current
1353	ELSE
1354	!-
1355	!---- If there are blanks whithin the line then we are dealing
1356	!---- with a vector and we need to split it in many entries
1357	!---- with the TARGET__n notation.
1358	!----
1359	!---- Test if the targer is not already a vector target !
1360	!-
1361	IF (INDEX(TRIM(key_str),'__') > 0) THEN
1362	CALL ipslerr (3,'getin_decrypt', &
1363	& 'We have found a mixed vector notation (TARGET__n).', &
1364	& 'The key at fault : '//TRIM(key_str),' ')
1365	ENDIF
1366	!-
1367	nbve = nb_lastkey
1368	nbve = nbve+1
1369	WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
1370	!-
1371	DO WHILE (blk > 0)
1372	!-
1373	!------ Save the content of target__nbve
1374	!-
1375	fichier(nb_lines) = tmp_str(1:blk)
1376	new_key = &
1377	& key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1378	targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
1379	fromfile(nb_lines) = current
1380	!-
1381	tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1382	blk = INDEX(TRIM(tmp_str),' ')
1383	!-
1384	IF (nb_lines+1 > i_txtsize) THEN
1385	CALL getin_alloctxt ()
1386	ENDIF
1387	nb_lines = nb_lines+1
1388	nbve = nbve+1
1389	WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
1390	!-
1391	ENDDO
1392	!-
1393	!---- Save the content of the last target
1394	!-
1395	fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
1396	new_key = &
1397	& key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1398	targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
1399	fromfile(nb_lines) = current
1400	!-
1401	last_key = &
1402	& key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1403	nb_lastkey = nbve
1404	!-
1405	ENDIF
1406	!-
1407	ENDIF
1408
1409	IF (l_dbg) THEN
1410	WRITE(,) "getin_decrypt ->",TRIM(NEW_str), " : ", &
1411	& TRIM(fichier(nb_lines)), &
1412	& fromfile(nb_lines), &
1413	& TRIM(filelist(fromfile(nb_lines)))
1414	WRITE(,) " compline : ",compline(nb_lines)
1415	WRITE(,) " targetlist : ",TRIM(targetlist(nb_lines))
1416	WRITE(,) " last_key : ",last_key
1417	ENDIF
1418	!---------------------------
1419	END SUBROUTINE getin_decrypt
1420	!-
1421	!===
1422	!-
1423	SUBROUTINE getin_checkcohe ()
1424	!---------------------------------------------------------------------
1425	!- This subroutine checks for redundancies.
1426	!---------------------------------------------------------------------
1427	IMPLICIT NONE
1428	!-
1429	INTEGER :: line,n_k,k
1430	!---------------------------------------------------------------------
1431	DO line=1,nb_lines-1
1432	!-
1433	n_k = 0
1434	DO k=line+1,nb_lines
1435	IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
1436	n_k = k
1437	EXIT
1438	ENDIF
1439	ENDDO
1440	!---
1441	!-- IF we have found it we have a problem to solve.
1442	!---
1443	IF (n_k > 0) THEN
1444	WRITE(,) 'COUNT : ',n_k
1445	WRITE(,) &
1446	& 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
1447	WRITE(,) &
1448	& 'getin_checkcohe : The following values were encoutered :'
1449	WRITE(,) &
1450	& ' ',TRIM(targetlist(line)),' == ',fichier(line)
1451	WRITE(,) &
1452	& ' ',TRIM(targetlist(k)),' == ',fichier(k)
1453	WRITE(,) &
1454	& 'getin_checkcohe : We will keep only the last value'
1455	CALL ipslerr (2,'getin_checkcohe','Found a problem on key ', &
1456	& TRIM(targetlist(line)), fichier(line)//" "//fichier(k))
1457	targetlist(line) = ' '
1458	ENDIF
1459	ENDDO
1460	!-----------------------------
1461	END SUBROUTINE getin_checkcohe
1462	!-
1463	!===
1464	!-
1465	SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
1466	!---------------------------------------------------------------------
1467	IMPLICIT NONE
1468	!-
1469	INTEGER :: unit,eof,nb_lastkey
1470	CHARACTER(LEN=100) :: dummy
1471	CHARACTER(LEN=100) :: out_string
1472	CHARACTER(LEN=1) :: first
1473	!---------------------------------------------------------------------
1474	first="#"
1475	eof = 0
1476	out_string = " "
1477	!-
1478	DO WHILE (first == "#")
1479	READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
1480	dummy = TRIM(ADJUSTL(dummy))
1481	first=dummy(1:1)
1482	IF (first == "#") THEN
1483	nb_lastkey = 0
1484	ENDIF
1485	ENDDO
1486	out_string=dummy
1487	!-
1488	RETURN
1489	!-
1490	9998 CONTINUE
1491	CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
1492	!-
1493	7778 CONTINUE
1494	eof = 1
1495	!----------------------------
1496	END SUBROUTINE getin_skipafew
1497	!-
1498	!===
1499	!-
1500	SUBROUTINE getin_allockeys ()
1501	!---------------------------------------------------------------------
1502	IMPLICIT NONE
1503	!-
1504	TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
1505	!-
1506	INTEGER :: ier
1507	CHARACTER(LEN=20) :: c_tmp
1508	!---------------------------------------------------------------------
1509	IF (keymemsize == 0) THEN
1510	!---
1511	!-- Nothing exists in memory arrays and it is easy to do.
1512	!---
1513	WRITE (UNIT=c_tmp,FMT=*) memslabs
1514	ALLOCATE(key_tab(memslabs),stat=ier)
1515	IF (ier /= 0) THEN
1516	CALL ipslerr (3,'getin_allockeys', &
1517	& 'Can not allocate key_tab', &
1518	& 'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1519	ENDIF
1520	nb_keys = 0
1521	keymemsize = memslabs
1522	key_tab(:)%keycompress = -1
1523	!---
1524	ELSE
1525	!---
1526	!-- There is something already in the memory,
1527	!-- we need to transfer and reallocate.
1528	!---
1529	WRITE (UNIT=c_tmp,FMT=*) keymemsize
1530	ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
1531	IF (ier /= 0) THEN
1532	CALL ipslerr (3,'getin_allockeys', &
1533	& 'Can not allocate tmp_key_tab', &
1534	& 'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1535	ENDIF
1536	WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
1537	tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
1538	DEALLOCATE(key_tab)
1539	ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
1540	IF (ier /= 0) THEN
1541	CALL ipslerr (3,'getin_allockeys', &
1542	& 'Can not allocate key_tab', &
1543	& 'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1544	ENDIF
1545	key_tab(:)%keycompress = -1
1546	key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
1547	DEALLOCATE(tmp_key_tab)
1548	keymemsize = keymemsize+memslabs
1549	ENDIF
1550	!-----------------------------
1551	END SUBROUTINE getin_allockeys
1552	!-
1553	!===
1554	!-
1555	SUBROUTINE getin_allocmem (type,len_wanted)
1556	!---------------------------------------------------------------------
1557	!- Allocate the memory of the data base for all 4 types of memory
1558	!- INTEGER / REAL / CHARACTER / LOGICAL
1559	!---------------------------------------------------------------------
1560	IMPLICIT NONE
1561	!-
1562	INTEGER :: type,len_wanted
1563	!-
1564	INTEGER,ALLOCATABLE :: tmp_int(:)
1565	REAL,ALLOCATABLE :: tmp_real(:)
1566	CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
1567	LOGICAL,ALLOCATABLE :: tmp_logic(:)
1568	INTEGER :: ier
1569	CHARACTER(LEN=20) :: c_tmp
1570	!---------------------------------------------------------------------
1571	SELECT CASE (type)
1572	CASE(k_i)
1573	IF (i_memsize == 0) THEN
1574	ALLOCATE(i_mem(memslabs),stat=ier)
1575	IF (ier /= 0) THEN
1576	WRITE (UNIT=c_tmp,FMT=*) memslabs
1577	CALL ipslerr (3,'getin_allocmem', &
1578	& 'Unable to allocate db-memory', &
1579	& 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1580	ENDIF
1581	i_memsize=memslabs
1582	ELSE
1583	ALLOCATE(tmp_int(i_memsize),stat=ier)
1584	IF (ier /= 0) THEN
1585	WRITE (UNIT=c_tmp,FMT=*) i_memsize
1586	CALL ipslerr (3,'getin_allocmem', &
1587	& 'Unable to allocate tmp_int', &
1588	& 'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1589	ENDIF
1590	tmp_int(1:i_memsize) = i_mem(1:i_memsize)
1591	DEALLOCATE(i_mem)
1592	ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
1593	IF (ier /= 0) THEN
1594	WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
1595	CALL ipslerr (3,'getin_allocmem', &
1596	& 'Unable to re-allocate db-memory', &
1597	& 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1598	ENDIF
1599	i_mem(1:i_memsize) = tmp_int(1:i_memsize)
1600	i_memsize = i_memsize+MAX(memslabs,len_wanted)
1601	DEALLOCATE(tmp_int)
1602	ENDIF
1603	CASE(k_r)
1604	IF (r_memsize == 0) THEN
1605	ALLOCATE(r_mem(memslabs),stat=ier)
1606	IF (ier /= 0) THEN
1607	WRITE (UNIT=c_tmp,FMT=*) memslabs
1608	CALL ipslerr (3,'getin_allocmem', &
1609	& 'Unable to allocate db-memory', &
1610	& 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1611	ENDIF
1612	r_memsize = memslabs
1613	ELSE
1614	ALLOCATE(tmp_real(r_memsize),stat=ier)
1615	IF (ier /= 0) THEN
1616	WRITE (UNIT=c_tmp,FMT=*) r_memsize
1617	CALL ipslerr (3,'getin_allocmem', &
1618	& 'Unable to allocate tmp_real', &
1619	& 'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1620	ENDIF
1621	tmp_real(1:r_memsize) = r_mem(1:r_memsize)
1622	DEALLOCATE(r_mem)
1623	ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
1624	IF (ier /= 0) THEN
1625	WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
1626	CALL ipslerr (3,'getin_allocmem', &
1627	& 'Unable to re-allocate db-memory', &
1628	& 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1629	ENDIF
1630	r_mem(1:r_memsize) = tmp_real(1:r_memsize)
1631	r_memsize = r_memsize+MAX(memslabs,len_wanted)
1632	DEALLOCATE(tmp_real)
1633	ENDIF
1634	CASE(k_c)
1635	IF (c_memsize == 0) THEN
1636	ALLOCATE(c_mem(memslabs),stat=ier)
1637	IF (ier /= 0) THEN
1638	WRITE (UNIT=c_tmp,FMT=*) memslabs
1639	CALL ipslerr (3,'getin_allocmem', &
1640	& 'Unable to allocate db-memory', &
1641	& 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1642	ENDIF
1643	c_memsize = memslabs
1644	ELSE
1645	ALLOCATE(tmp_char(c_memsize),stat=ier)
1646	IF (ier /= 0) THEN
1647	WRITE (UNIT=c_tmp,FMT=*) c_memsize
1648	CALL ipslerr (3,'getin_allocmem', &
1649	& 'Unable to allocate tmp_char', &
1650	& 'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1651	ENDIF
1652	tmp_char(1:c_memsize) = c_mem(1:c_memsize)
1653	DEALLOCATE(c_mem)
1654	ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
1655	IF (ier /= 0) THEN
1656	WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
1657	CALL ipslerr (3,'getin_allocmem', &
1658	& 'Unable to re-allocate db-memory', &
1659	& 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1660	ENDIF
1661	c_mem(1:c_memsize) = tmp_char(1:c_memsize)
1662	c_memsize = c_memsize+MAX(memslabs,len_wanted)
1663	DEALLOCATE(tmp_char)
1664	ENDIF
1665	CASE(k_l)
1666	IF (l_memsize == 0) THEN
1667	ALLOCATE(l_mem(memslabs),stat=ier)
1668	IF (ier /= 0) THEN
1669	WRITE (UNIT=c_tmp,FMT=*) memslabs
1670	CALL ipslerr (3,'getin_allocmem', &
1671	& 'Unable to allocate db-memory', &
1672	& 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1673	ENDIF
1674	l_memsize = memslabs
1675	ELSE
1676	ALLOCATE(tmp_logic(l_memsize),stat=ier)
1677	IF (ier /= 0) THEN
1678	WRITE (UNIT=c_tmp,FMT=*) l_memsize
1679	CALL ipslerr (3,'getin_allocmem', &
1680	& 'Unable to allocate tmp_logic', &
1681	& 'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1682	ENDIF
1683	tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
1684	DEALLOCATE(l_mem)
1685	ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
1686	IF (ier /= 0) THEN
1687	WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
1688	CALL ipslerr (3,'getin_allocmem', &
1689	& 'Unable to re-allocate db-memory', &
1690	& 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1691	ENDIF
1692	l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
1693	l_memsize = l_memsize+MAX(memslabs,len_wanted)
1694	DEALLOCATE(tmp_logic)
1695	ENDIF
1696	CASE DEFAULT
1697	CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
1698	END SELECT
1699	!----------------------------
1700	END SUBROUTINE getin_allocmem
1701	!-
1702	!===
1703	!-
1704	SUBROUTINE getin_alloctxt ()
1705	!---------------------------------------------------------------------
1706	IMPLICIT NONE
1707	!-
1708	CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
1709	CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
1710	INTEGER,ALLOCATABLE :: tmp_int(:)
1711	!-
1712	INTEGER :: ier
1713	CHARACTER(LEN=20) :: c_tmp1,c_tmp2
1714	!---------------------------------------------------------------------
1715	IF (i_txtsize == 0) THEN
1716	!---
1717	!-- Nothing exists in memory arrays and it is easy to do.
1718	!---
1719	WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
1720	ALLOCATE(fichier(i_txtslab),stat=ier)
1721	IF (ier /= 0) THEN
1722	CALL ipslerr (3,'getin_alloctxt', &
1723	& 'Can not allocate fichier', &
1724	& 'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1725	ENDIF
1726	!---
1727	ALLOCATE(targetlist(i_txtslab),stat=ier)
1728	IF (ier /= 0) THEN
1729	CALL ipslerr (3,'getin_alloctxt', &
1730	& 'Can not allocate targetlist', &
1731	& 'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1732	ENDIF
1733	!---
1734	ALLOCATE(fromfile(i_txtslab),stat=ier)
1735	IF (ier /= 0) THEN
1736	CALL ipslerr (3,'getin_alloctxt', &
1737	& 'Can not allocate fromfile', &
1738	& 'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1739	ENDIF
1740	!---
1741	ALLOCATE(compline(i_txtslab),stat=ier)
1742	IF (ier /= 0) THEN
1743	CALL ipslerr (3,'getin_alloctxt', &
1744	& 'Can not allocate compline', &
1745	& 'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1746	ENDIF
1747	!---
1748	nb_lines = 0
1749	i_txtsize = i_txtslab
1750	ELSE
1751	!---
1752	!-- There is something already in the memory,
1753	!-- we need to transfer and reallocate.
1754	!---
1755	WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
1756	WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
1757	ALLOCATE(tmp_fic(i_txtsize),stat=ier)
1758	IF (ier /= 0) THEN
1759	CALL ipslerr (3,'getin_alloctxt', &
1760	& 'Can not allocate tmp_fic', &
1761	& 'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1762	ENDIF
1763	tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
1764	DEALLOCATE(fichier)
1765	ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
1766	IF (ier /= 0) THEN
1767	CALL ipslerr (3,'getin_alloctxt', &
1768	& 'Can not allocate fichier', &
1769	& 'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1770	ENDIF
1771	fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
1772	DEALLOCATE(tmp_fic)
1773	!---
1774	ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
1775	IF (ier /= 0) THEN
1776	CALL ipslerr (3,'getin_alloctxt', &
1777	& 'Can not allocate tmp_tgl', &
1778	& 'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1779	ENDIF
1780	tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
1781	DEALLOCATE(targetlist)
1782	ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
1783	IF (ier /= 0) THEN
1784	CALL ipslerr (3,'getin_alloctxt', &
1785	& 'Can not allocate targetlist', &
1786	& 'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1787	ENDIF
1788	targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
1789	DEALLOCATE(tmp_tgl)
1790	!---
1791	ALLOCATE(tmp_int(i_txtsize),stat=ier)
1792	IF (ier /= 0) THEN
1793	CALL ipslerr (3,'getin_alloctxt', &
1794	& 'Can not allocate tmp_int', &
1795	& 'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1796	ENDIF
1797	tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
1798	DEALLOCATE(fromfile)
1799	ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
1800	IF (ier /= 0) THEN
1801	CALL ipslerr (3,'getin_alloctxt', &
1802	& 'Can not allocate fromfile', &
1803	& 'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1804	ENDIF
1805	fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
1806	!---
1807	tmp_int(1:i_txtsize) = compline(1:i_txtsize)
1808	DEALLOCATE(compline)
1809	ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
1810	IF (ier /= 0) THEN
1811	CALL ipslerr (3,'getin_alloctxt', &
1812	& 'Can not allocate compline', &
1813	& 'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1814	ENDIF
1815	compline(1:i_txtsize) = tmp_int(1:i_txtsize)
1816	DEALLOCATE(tmp_int)
1817	!---
1818	i_txtsize = i_txtsize+i_txtslab
1819	ENDIF
1820	!----------------------------
1821	END SUBROUTINE getin_alloctxt
1822	!-
1823	!===
1824	!-
1825	SUBROUTINE getin_dump (fileprefix)
1826	!---------------------------------------------------------------------
1827	IMPLICIT NONE
1828	!-
1829	CHARACTER(*),OPTIONAL :: fileprefix
1830	!-
1831	CHARACTER(LEN=80) :: usedfileprefix
1832	INTEGER :: ikey,if,iff,iv
1833	INTEGER :: ios
1834	CHARACTER(LEN=20) :: c_tmp
1835	CHARACTER(LEN=100) :: tmp_str,used_filename
1836	INTEGER :: io_err
1837	LOGICAL :: l_dbg
1838	!---------------------------------------------------------------------
1839	CALL ipsldbg (old_status=l_dbg)
1840	!---------------------------------------------------------------------
1841	IF (PRESENT(fileprefix)) THEN
1842	usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
1843	ELSE
1844	usedfileprefix = "used"
1845	ENDIF
1846	!-
1847	DO if=1,nbfiles
1848	!---
1849	used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
1850	IF (l_dbg) THEN
1851	WRITE(,) &
1852	& 'getin_dump : opens file : ',TRIM(used_filename),' if = ',if
1853	WRITE(,) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
1854	ENDIF
1855	OPEN (UNIT=22,FILE=used_filename,iostat=io_err)
1856	IF (io_err /= 0) THEN
1857	CALL ipslerr (3,'getin_dump', &
1858	& 'Could not open file :',TRIM(used_filename), &
1859	& '')
1860	ENDIF
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	IF (l_dbg) THEN
1873	WRITE(,) '# '
1874	WRITE(,) '# This file is linked to the following files :'
1875	WRITE(,) '# '
1876	DO iff=2,nbfiles
1877	WRITE(,) 'INCLUDEDEF = ',TRIM(filelist(iff))
1878	ENDDO
1879	WRITE(,) '# '
1880	ENDIF
1881	ENDIF
1882	!---
1883	DO ikey=1,nb_keys
1884	!-----
1885	!---- Is this key from this file ?
1886	IF (key_tab(ikey)%keyfromfile == if) THEN
1887	!-------
1888	!------ Write some comments
1889	WRITE(22,*) '#'
1890	SELECT CASE (key_tab(ikey)%keystatus)
1891	CASE(nondefault)
1892	WRITE(22,*) '# Values of ', &
1893	& TRIM(key_tab(ikey)%keystr),' comes from ',TRIM(def_file)
1894	CASE(default)
1895	WRITE(22,*) '# Values of ', &
1896	& TRIM(key_tab(ikey)%keystr),' are all defaults.'
1897	CASE(vectornondefault)
1898	WRITE(22,*) '# Values of ', &
1899	& TRIM(key_tab(ikey)%keystr), &
1900	& ' are a mix of ',TRIM(def_file),' and defaults.'
1901	CASE DEFAULT
1902	WRITE(22,*) '# Dont know from where the value of ', &
1903	& TRIM(key_tab(ikey)%keystr),' comes.'
1904	END SELECT
1905	WRITE(22,*) '#'
1906	!-
1907	IF (l_dbg) THEN
1908	WRITE(,) '#'
1909	WRITE(,) '# Status of key ', ikey, ' : ',&
1910	& TRIM(key_tab(ikey)%keystr),key_tab(ikey)%keystatus
1911	ENDIF
1912	!-------
1913	!------ Write the values
1914	SELECT CASE (key_tab(ikey)%keytype)
1915	CASE(k_i)
1916	IF (key_tab(ikey)%keymemlen == 1) THEN
1917	IF (key_tab(ikey)%keycompress < 0) THEN
1918	WRITE(22,*) &
1919	& TRIM(key_tab(ikey)%keystr), &
1920	& ' = ',i_mem(key_tab(ikey)%keymemstart)
1921	ELSE
1922	WRITE(22,*) &
1923	& TRIM(key_tab(ikey)%keystr), &
1924	& ' = ',key_tab(ikey)%keycompress, &
1925	& ' * ',i_mem(key_tab(ikey)%keymemstart)
1926	ENDIF
1927	ELSE
1928	DO iv=0,key_tab(ikey)%keymemlen-1
1929	WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1930	WRITE(22,*) &
1931	& TRIM(key_tab(ikey)%keystr), &
1932	& '__',TRIM(ADJUSTL(c_tmp)), &
1933	& ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
1934	ENDDO
1935	ENDIF
1936	CASE(k_r)
1937	IF (key_tab(ikey)%keymemlen == 1) THEN
1938	IF (key_tab(ikey)%keycompress < 0) THEN
1939	WRITE(22,*) &
1940	& TRIM(key_tab(ikey)%keystr), &
1941	& ' = ',r_mem(key_tab(ikey)%keymemstart)
1942	ELSE
1943	WRITE(22,*) &
1944	& TRIM(key_tab(ikey)%keystr), &
1945	& ' = ',key_tab(ikey)%keycompress, &
1946	& ' * ',r_mem(key_tab(ikey)%keymemstart)
1947	ENDIF
1948	ELSE
1949	DO iv=0,key_tab(ikey)%keymemlen-1
1950	WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1951	WRITE(22,*) &
1952	& TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
1953	& ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
1954	ENDDO
1955	ENDIF
1956	CASE(k_c)
1957	IF (key_tab(ikey)%keymemlen == 1) THEN
1958	tmp_str = c_mem(key_tab(ikey)%keymemstart)
1959	WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
1960	& ' = ',TRIM(tmp_str)
1961	ELSE
1962	DO iv=0,key_tab(ikey)%keymemlen-1
1963	WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1964	tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
1965	WRITE(22,*) &
1966	& TRIM(key_tab(ikey)%keystr), &
1967	& '__',TRIM(ADJUSTL(c_tmp)), &
1968	& ' = ',TRIM(tmp_str)
1969	ENDDO
1970	ENDIF
1971	CASE(k_l)
1972	IF (key_tab(ikey)%keymemlen == 1) THEN
1973	IF (l_mem(key_tab(ikey)%keymemstart)) THEN
1974	WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
1975	ELSE
1976	WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
1977	ENDIF
1978	ELSE
1979	DO iv=0,key_tab(ikey)%keymemlen-1
1980	WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1981	IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
1982	WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
1983	& TRIM(ADJUSTL(c_tmp)),' = TRUE '
1984	ELSE
1985	WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
1986	& TRIM(ADJUSTL(c_tmp)),' = FALSE '
1987	ENDIF
1988	ENDDO
1989	ENDIF
1990	CASE DEFAULT
1991	CALL ipslerr (3,'getin_dump', &
1992	& 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
1993	& ' ',' ')
1994	END SELECT
1995	ENDIF
1996	ENDDO
1997	!-
1998	CLOSE(UNIT=22)
1999	!-
2000	ENDDO
2001	!------------------------
2002	END SUBROUTINE getin_dump
2003	!===
2004	SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
2005	!---------------------------------------------------------------------
2006	!- Returns the type of the argument (mutually exclusive)
2007	!---------------------------------------------------------------------
2008	IMPLICIT NONE
2009	!-
2010	INTEGER,INTENT(OUT) :: k_typ
2011	CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
2012	INTEGER,DIMENSION(:),OPTIONAL :: i_v
2013	REAL,DIMENSION(:),OPTIONAL :: r_v
2014	LOGICAL,DIMENSION(:),OPTIONAL :: l_v
2015	CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
2016	!---------------------------------------------------------------------
2017	k_typ = 0
2018	IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
2019	& /= 1) THEN
2020	CALL ipslerr (3,'get_qtyp', &
2021	& 'Invalid number of optional arguments','(/= 1)',' ')
2022	ENDIF
2023	!-
2024	IF (PRESENT(i_v)) THEN
2025	k_typ = k_i
2026	c_vtyp = 'INTEGER'
2027	ELSEIF (PRESENT(r_v)) THEN
2028	k_typ = k_r
2029	c_vtyp = 'REAL'
2030	ELSEIF (PRESENT(c_v)) THEN
2031	k_typ = k_c
2032	c_vtyp = 'CHARACTER'
2033	ELSEIF (PRESENT(l_v)) THEN
2034	k_typ = k_l
2035	c_vtyp = 'LOGICAL'
2036	ENDIF
2037	!----------------------
2038	END SUBROUTINE get_qtyp
2039	!===
2040	SUBROUTINE get_findkey (i_tab,c_key,pos)
2041	!---------------------------------------------------------------------
2042	!- This subroutine looks for a key in a table
2043	!---------------------------------------------------------------------
2044	!- INPUT
2045	!- i_tab : 1 -> search in key_tab(1:nb_keys)%keystr
2046	!- 2 -> search in targetlist(1:nb_lines)
2047	!- c_key : Name of the key we are looking for
2048	!- OUTPUT
2049	!- pos : -1 if key not found, else value in the table
2050	!---------------------------------------------------------------------
2051	IMPLICIT NONE
2052	!-
2053	INTEGER,INTENT(in) :: i_tab
2054	CHARACTER(LEN=*),INTENT(in) :: c_key
2055	INTEGER,INTENT(out) :: pos
2056	!-
2057	INTEGER :: ikey_max,ikey
2058	CHARACTER(LEN=l_n) :: c_q_key
2059	!---------------------------------------------------------------------
2060	pos = -1
2061	IF (i_tab == 1) THEN
2062	ikey_max = nb_keys
2063	ELSEIF (i_tab == 2) THEN
2064	ikey_max = nb_lines
2065	ELSE
2066	ikey_max = 0
2067	ENDIF
2068	IF ( ikey_max > 0 ) THEN
2069	DO ikey=1,ikey_max
2070	IF (i_tab == 1) THEN
2071	c_q_key = key_tab(ikey)%keystr
2072	ELSE
2073	c_q_key = targetlist(ikey)
2074	ENDIF
2075	IF (TRIM(c_q_key) == TRIM(c_key)) THEN
2076	pos = ikey
2077	EXIT
2078	ENDIF
2079	ENDDO
2080	ENDIF
2081	!-------------------------
2082	END SUBROUTINE get_findkey
2083	!===
2084	!------------------
2085	END MODULE getincom

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

Download in other formats: