Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

getincom.f90 @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 65.2 KB

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

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

Download in other formats:

Original Format