Context Navigation

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

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

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

Download in other formats: