Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

ioipsl_getincom.F90 @ 3657

Last change on this file since 3657 was 1279, checked in by Laurent Fairhead, 15 years ago
Merged LMDZ4-dev branch changes r1241:1278 into the trunk Running trunk and LMDZ4-dev in LMDZOR configuration on local machine (sequential) and SX8 (4-proc) yields identical results (restart and restartphy are identical binarily) Log history from r1241 to r1278 is available by switching to source:LMDZ4/branches/LMDZ4-dev-20091210
File size: 58.5 KB

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

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

Download in other formats:

Original Format