1 |
MODULE getincom |
MODULE getincom |
2 |
|
|
3 |
! From getincom.f90,v 2.0 2004/04/05 14:47:48 |
! From getincom.f90, version 2.0 2004/04/05 14:47:48 |
4 |
|
|
|
USE nocomma_m, ONLY : nocomma |
|
|
use cmpblank_m, only: cmpblank |
|
|
use strlowercase_m, only: strlowercase |
|
5 |
use gensig_m, only: gensig |
use gensig_m, only: gensig |
6 |
use find_sig_m, only: find_sig |
use find_sig_m, only: find_sig |
7 |
|
use getincom2, only: nb_keys, keysig, keystr, getfill, getdbwl, getdbrl, & |
8 |
|
getfilc, getdbwc, getdbrc, getfili, getdbwi, getdbri, getfilr, & |
9 |
|
getdbwr, getdbrr |
10 |
|
|
11 |
IMPLICIT NONE |
IMPLICIT NONE |
12 |
|
|
13 |
PRIVATE |
PRIVATE |
14 |
PUBLIC :: getin |
PUBLIC getin |
15 |
|
|
16 |
INTERFACE getin |
INTERFACE getin |
17 |
MODULE PROCEDURE getinrs, getinr1d, getinr2d, & |
MODULE PROCEDURE getinrs, getinr1d, getinr2d, getinis, getini1d, & |
18 |
& getinis, getini1d, getini2d, & |
getini2d, getincs, getinc1d, getinc2d, getinls, getinl1d, getinl2d |
|
& getincs, getinc1d, getinc2d, & |
|
|
& getinls, getinl1d, getinl2d |
|
19 |
END INTERFACE |
END INTERFACE |
20 |
|
|
|
INTEGER,PARAMETER :: max_files=100 |
|
|
CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist |
|
|
INTEGER,SAVE :: nbfiles |
|
|
|
|
|
INTEGER,PARAMETER :: max_lines=500 |
|
|
INTEGER,SAVE :: nb_lines |
|
|
CHARACTER(LEN=100),DIMENSION(max_lines),SAVE :: fichier |
|
|
INTEGER,DIMENSION(max_lines),SAVE :: targetsiglist,fromfile,compline |
|
|
CHARACTER(LEN=30),DIMENSION(max_lines),SAVE :: targetlist |
|
|
|
|
|
! The data base of parameters |
|
|
|
|
|
INTEGER,PARAMETER :: memslabs=200 |
|
|
INTEGER,PARAMETER :: compress_lim = 20 |
|
|
|
|
|
INTEGER,SAVE :: nb_keys=0 |
|
|
INTEGER,SAVE :: keymemsize=0 |
|
|
INTEGER,SAVE,ALLOCATABLE :: keysig(:) |
|
|
CHARACTER(LEN=30),SAVE,ALLOCATABLE :: keystr(:) |
|
|
|
|
|
! keystatus definition |
|
|
! keystatus = 1 : Value comes from run.def |
|
|
! keystatus = 2 : Default value is used |
|
|
! keystatus = 3 : Some vector elements were taken from default |
|
|
|
|
|
INTEGER,SAVE,ALLOCATABLE :: keystatus(:) |
|
|
|
|
|
! keytype definition |
|
|
! keytype = 1 : Interger |
|
|
! keytype = 2 : Real |
|
|
! keytype = 3 : Character |
|
|
! keytype = 4 : Logical |
|
|
|
|
|
INTEGER,SAVE,ALLOCATABLE :: keytype(:) |
|
|
|
|
|
! Allow compression for keys (only for integer and real) |
|
|
! keycompress < 0 : not compresses |
|
|
! keycompress > 0 : number of repeat of the value |
|
|
|
|
|
INTEGER,SAVE,ALLOCATABLE :: keycompress(:) |
|
|
INTEGER,SAVE,ALLOCATABLE :: keyfromfile(:) |
|
|
|
|
|
INTEGER,SAVE,ALLOCATABLE :: keymemstart(:) |
|
|
INTEGER,SAVE,ALLOCATABLE :: keymemlen(:) |
|
|
|
|
|
INTEGER,SAVE,ALLOCATABLE :: intmem(:) |
|
|
INTEGER,SAVE :: intmemsize=0, intmempos=0 |
|
|
REAL,SAVE,ALLOCATABLE :: realmem(:) |
|
|
INTEGER,SAVE :: realmemsize=0, realmempos=0 |
|
|
CHARACTER(LEN=100),SAVE,ALLOCATABLE :: charmem(:) |
|
|
INTEGER,SAVE :: charmemsize=0, charmempos=0 |
|
|
LOGICAL,SAVE,ALLOCATABLE :: logicmem(:) |
|
|
INTEGER,SAVE :: logicmemsize=0, logicmempos=0 |
|
|
|
|
21 |
CONTAINS |
CONTAINS |
22 |
|
|
23 |
!=== REAL INTERFACES |
SUBROUTINE getinrs(MY_TARGET, ret_val) |
24 |
|
|
25 |
|
! Get a real scalar. We first check whether we find it in the |
26 |
|
! database and if not we get it from "run.def". "getinr1d" and |
27 |
|
! "getinr2d" are written on the same pattern. |
28 |
|
|
29 |
|
CHARACTER(LEN=*) MY_TARGET |
30 |
|
REAL ret_val |
31 |
|
|
32 |
|
! Local: |
33 |
|
REAL, DIMENSION(1):: tmp_ret_val |
34 |
|
INTEGER:: target_sig, pos, status = 0, fileorig |
35 |
|
|
36 |
|
!-------------------------------------------------------------------- |
37 |
|
|
|
SUBROUTINE getinrs (TARGET,ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Get a real scalar. We first check if we find it |
|
|
!- in the database and if not we get it from the run.def |
|
|
|
|
|
!- getinr1d and getinr2d are written on the same pattern |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: TARGET |
|
|
REAL :: ret_val |
|
|
|
|
|
REAL,DIMENSION(1) :: tmp_ret_val |
|
|
INTEGER :: target_sig, pos, status=0, fileorig |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
38 |
! Compute the signature of the target |
! Compute the signature of the target |
39 |
|
CALL gensig(MY_TARGET, target_sig) |
40 |
CALL gensig (TARGET,target_sig) |
|
41 |
|
! Do we have this my_target in our database ? |
|
! Do we have this target in our database ? |
|
42 |
|
|
|
! Modification by Lionel GUEZ, April 4th, 2007 |
|
43 |
! "find_sig" should not be called if "keystr" and "keysig" are not |
! "find_sig" should not be called if "keystr" and "keysig" are not |
44 |
! allocated. |
! allocated. |
45 |
! Avoid this problem with a test on "nb_keys": |
! Avoid this problem with a test on "nb_keys": |
46 |
if (nb_keys > 0) then |
if (nb_keys > 0) then |
47 |
CALL find_sig(nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig(nb_keys, keystr, my_target, keysig, target_sig, pos) |
48 |
else |
else |
49 |
pos = -1 |
pos = -1 |
50 |
end if |
end if |
51 |
|
|
52 |
tmp_ret_val(1) = ret_val |
tmp_ret_val(1) = ret_val |
53 |
|
|
54 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
55 |
!-- Get the information out of the file |
! Get the information out of the file |
56 |
CALL getfilr (TARGET,status,fileorig,tmp_ret_val) |
CALL getfilr(MY_TARGET, status, fileorig, tmp_ret_val) |
57 |
!-- Put the data into the database |
! Put the data into the database |
58 |
CALL getdbwr (TARGET,target_sig,status,fileorig,1,tmp_ret_val) |
CALL getdbwr(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val) |
59 |
ELSE |
ELSE |
60 |
!-- Get the value out of the database |
! Get the value out of the database |
61 |
CALL getdbrr (pos,1,TARGET,tmp_ret_val) |
CALL getdbrr (pos, 1, MY_TARGET, tmp_ret_val) |
62 |
ENDIF |
ENDIF |
63 |
ret_val = tmp_ret_val(1) |
ret_val = tmp_ret_val(1) |
64 |
!--------------------- |
|
65 |
END SUBROUTINE getinrs |
END SUBROUTINE getinrs |
66 |
|
|
67 |
!**************************** |
!**************************** |
68 |
|
|
69 |
SUBROUTINE getinr1d (TARGET,ret_val) |
SUBROUTINE getinr1d(MY_TARGET, ret_val) |
70 |
!--------------------------------------------------------------------- |
|
71 |
!- See getinrs for details. It is the same thing but for a vector |
! See getinrs for details. It is the same thing but for a vector |
72 |
!--------------------------------------------------------------------- |
|
73 |
|
|
74 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
75 |
REAL,DIMENSION(:) :: ret_val |
REAL, DIMENSION(:) :: ret_val |
76 |
|
|
77 |
REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
REAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
78 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
79 |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
80 |
!--------------------------------------------------------------------- |
|
81 |
|
|
82 |
! Compute the signature of the target |
! Compute the signature of the target |
83 |
|
|
84 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
85 |
|
|
86 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
87 |
|
|
88 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
89 |
|
|
90 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
91 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
92 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
96 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
97 |
ENDIF |
ENDIF |
98 |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
99 |
|
|
100 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
101 |
!-- Ge the information out of the file |
! Ge the information out of the file |
102 |
CALL getfilr (TARGET,status,fileorig,tmp_ret_val) |
CALL getfilr(MY_TARGET, status, fileorig, tmp_ret_val) |
103 |
!-- Put the data into the database |
! Put the data into the database |
104 |
CALL getdbwr & |
CALL getdbwr & |
105 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
106 |
ELSE |
ELSE |
107 |
!-- Get the value out of the database |
! Get the value out of the database |
108 |
CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbrr (pos, size_of_in, MY_TARGET, tmp_ret_val) |
109 |
ENDIF |
ENDIF |
110 |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
111 |
!---------------------- |
|
112 |
END SUBROUTINE getinr1d |
END SUBROUTINE getinr1d |
113 |
|
|
114 |
!**************************** |
!**************************** |
115 |
|
|
116 |
SUBROUTINE getinr2d (TARGET,ret_val) |
SUBROUTINE getinr2d(MY_TARGET, ret_val) |
117 |
!--------------------------------------------------------------------- |
|
118 |
!- See getinrs for details. It is the same thing but for a matrix |
! See getinrs for details. It is the same thing but for a matrix |
119 |
!--------------------------------------------------------------------- |
|
120 |
|
|
121 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
122 |
REAL,DIMENSION(:,:) :: ret_val |
REAL, DIMENSION(:, :) :: ret_val |
123 |
|
|
124 |
REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
REAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
125 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
126 |
INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig |
INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig |
127 |
INTEGER :: jl, jj, ji |
INTEGER :: jl, jj, ji |
128 |
!--------------------------------------------------------------------- |
|
129 |
|
|
130 |
! Compute the signature of the target |
! Compute the signature of the target |
131 |
|
|
132 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
133 |
|
|
134 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
135 |
|
|
136 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
137 |
|
|
138 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
139 |
size_1 = SIZE(ret_val,1) |
size_1 = SIZE(ret_val, 1) |
140 |
size_2 = SIZE(ret_val,2) |
size_2 = SIZE(ret_val, 2) |
141 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
142 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
143 |
ELSE IF (size_of_in > tmp_ret_size) THEN |
ELSE IF (size_of_in > tmp_ret_size) THEN |
145 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
146 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
147 |
ENDIF |
ENDIF |
148 |
|
|
149 |
jl=0 |
jl=0 |
150 |
DO jj=1,size_2 |
DO jj=1, size_2 |
151 |
DO ji=1,size_1 |
DO ji=1, size_1 |
152 |
jl=jl+1 |
jl=jl+1 |
153 |
tmp_ret_val(jl) = ret_val(ji,jj) |
tmp_ret_val(jl) = ret_val(ji, jj) |
154 |
ENDDO |
ENDDO |
155 |
ENDDO |
ENDDO |
156 |
|
|
157 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
158 |
!-- Ge the information out of the file |
! Ge the information out of the file |
159 |
CALL getfilr (TARGET,status,fileorig,tmp_ret_val) |
CALL getfilr(MY_TARGET, status, fileorig, tmp_ret_val) |
160 |
!-- Put the data into the database |
! Put the data into the database |
161 |
CALL getdbwr & |
CALL getdbwr & |
162 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
163 |
ELSE |
ELSE |
164 |
!-- Get the value out of the database |
! Get the value out of the database |
165 |
CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbrr (pos, size_of_in, MY_TARGET, tmp_ret_val) |
166 |
ENDIF |
ENDIF |
167 |
|
|
168 |
jl=0 |
jl=0 |
169 |
DO jj=1,size_2 |
DO jj=1, size_2 |
170 |
DO ji=1,size_1 |
DO ji=1, size_1 |
171 |
jl=jl+1 |
jl=jl+1 |
172 |
ret_val(ji,jj) = tmp_ret_val(jl) |
ret_val(ji, jj) = tmp_ret_val(jl) |
173 |
ENDDO |
ENDDO |
174 |
ENDDO |
ENDDO |
175 |
!---------------------- |
|
176 |
END SUBROUTINE getinr2d |
END SUBROUTINE getinr2d |
177 |
|
|
178 |
!**************************** |
!**************************** |
179 |
|
|
180 |
SUBROUTINE getfilr (TARGET,status,fileorig,ret_val) |
SUBROUTINE getinis(MY_TARGET, ret_val) |
181 |
!--------------------------------------------------------------------- |
|
182 |
!- Subroutine that will extract from the file the values |
! Get a interer scalar. We first check if we find it |
183 |
!- attributed to the keyword target |
! in the database and if not we get it from the run.def |
184 |
|
|
185 |
!- REALS |
! getini1d and getini2d are written on the same pattern |
|
!- ----- |
|
|
|
|
|
!- target : in : CHARACTER(LEN=*) target for which we will |
|
|
!- look in the file |
|
|
!- status : out : INTEGER tells us from where we obtained the data |
|
|
!- fileorig : out : The index of the file from which the key comes |
|
|
!- ret_val : out : REAL(nb_to_ret) values read |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: TARGET |
|
|
INTEGER :: status, fileorig |
|
|
REAL,DIMENSION(:) :: ret_val |
|
|
|
|
|
INTEGER :: nb_to_ret |
|
|
INTEGER :: it, pos, len_str, epos, ppos, int_tmp, status_cnt |
|
|
CHARACTER(LEN=3) :: cnt, tl, dl |
|
|
CHARACTER(LEN=10) :: fmt |
|
|
CHARACTER(LEN=30) :: full_target |
|
|
CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp |
|
|
INTEGER :: full_target_sig |
|
|
REAL :: compvalue |
|
|
|
|
|
INTEGER,SAVE :: max_len = 0 |
|
|
LOGICAL,SAVE,ALLOCATABLE :: found(:) |
|
|
LOGICAL :: def_beha |
|
|
LOGICAL :: compressed = .FALSE. |
|
|
!--------------------------------------------------------------------- |
|
|
nb_to_ret = SIZE(ret_val) |
|
|
CALL getin_read |
|
|
|
|
|
! Get the variables and memory we need |
|
|
|
|
|
IF (max_len == 0) THEN |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
IF (max_len < nb_to_ret) THEN |
|
|
DEALLOCATE(found) |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
found(:) = .FALSE. |
|
|
|
|
|
! See what we find in the files read |
|
|
|
|
|
DO it=1,nb_to_ret |
|
|
!--- |
|
|
|
|
|
!-- First try the target as it is |
|
|
!--- |
|
|
full_target = TARGET(1:len_TRIM(target)) |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
!--- |
|
|
!-- Another try |
|
|
!--- |
|
|
IF (pos < 0) THEN |
|
|
WRITE(cnt,'(I3.3)') it |
|
|
full_target = TARGET(1:len_TRIM(target))//'__'//cnt |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
ENDIF |
|
|
!--- |
|
|
!-- A priori we dont know from which file the target could come. |
|
|
!-- Thus by default we attribute it to the first file : |
|
|
!--- |
|
|
fileorig = 1 |
|
|
!-- |
|
|
IF (pos > 0) THEN |
|
|
!---- |
|
|
found(it) = .TRUE. |
|
|
fileorig = fromfile(pos) |
|
|
!----- |
|
|
!---- DECODE |
|
|
!----- |
|
|
str_READ = TRIM(ADJUSTL(fichier(pos))) |
|
|
str_READ_lower = str_READ |
|
|
CALL strlowercase (str_READ_lower) |
|
|
!---- |
|
|
IF ( ( (INDEX(str_READ_lower,'def') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 3) ) & |
|
|
& .OR.( (INDEX(str_READ_lower,'default') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN |
|
|
def_beha = .TRUE. |
|
|
ELSE |
|
|
def_beha = .FALSE. |
|
|
len_str = LEN_TRIM(str_READ) |
|
|
epos = INDEX(str_READ,'e') |
|
|
ppos = INDEX(str_READ,'.') |
|
|
!------ |
|
|
IF (epos > 0) THEN |
|
|
WRITE(tl,'(I3.3)') len_str |
|
|
WRITE(dl,'(I3.3)') epos-ppos-1 |
|
|
fmt='(e'//tl//'.'//dl//')' |
|
|
READ(str_READ,fmt) ret_val(it) |
|
|
ELSE IF (ppos > 0) THEN |
|
|
WRITE(tl,'(I3.3)') len_str |
|
|
WRITE(dl,'(I3.3)') len_str-ppos |
|
|
fmt='(f'//tl//'.'//dl//')' |
|
|
READ(str_READ,fmt) ret_val(it) |
|
|
ELSE |
|
|
WRITE(tl,'(I3.3)') len_str |
|
|
fmt = '(I'//tl//')' |
|
|
READ(str_READ,fmt) int_tmp |
|
|
ret_val(it) = REAL(int_tmp) |
|
|
ENDIF |
|
|
ENDIF |
|
|
!---- |
|
|
targetsiglist(pos) = -1 |
|
|
!----- |
|
|
!---- Is this the value of a compressed field ? |
|
|
!----- |
|
|
IF (compline(pos) > 0) THEN |
|
|
IF (compline(pos) == nb_to_ret) THEN |
|
|
compressed = .TRUE. |
|
|
compvalue = ret_val(it) |
|
|
ELSE |
|
|
WRITE(*,*) 'WARNING from getfilr' |
|
|
WRITE(*,*) 'For key ',TRIM(TARGET), & |
|
|
& ' we have a compressed field but which does not have the right size.' |
|
|
WRITE(*,*) 'We will try to fix that ' |
|
|
compressed = .TRUE. |
|
|
compvalue = ret_val(it) |
|
|
ENDIF |
|
|
ENDIF |
|
|
ELSE |
|
|
found(it) = .FALSE. |
|
|
ENDIF |
|
|
ENDDO |
|
|
!-- |
|
|
! If this is a compressed field then we will uncompress it |
|
|
!-- |
|
|
IF (compressed) THEN |
|
|
DO it=1,nb_to_ret |
|
|
IF (.NOT. found(it)) THEN |
|
|
ret_val(it) = compvalue |
|
|
found(it) = .TRUE. |
|
|
ENDIF |
|
|
ENDDO |
|
|
ENDIF |
|
|
|
|
|
! Now we get the status for what we found |
|
|
|
|
|
IF (def_beha) THEN |
|
|
status = 2 |
|
|
WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) |
|
|
ELSE |
|
|
status_cnt = 0 |
|
|
DO it=1,nb_to_ret |
|
|
IF (.NOT. found(it)) THEN |
|
|
status_cnt = status_cnt+1 |
|
|
IF (nb_to_ret > 1) THEN |
|
|
WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it |
|
|
ELSE |
|
|
str_tmp = TRIM(TARGET) |
|
|
ENDIF |
|
|
WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) |
|
|
ENDIF |
|
|
ENDDO |
|
|
!--- |
|
|
IF (status_cnt == 0) THEN |
|
|
status = 1 |
|
|
ELSE IF (status_cnt == nb_to_ret) THEN |
|
|
status = 2 |
|
|
ELSE |
|
|
status = 3 |
|
|
ENDIF |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getfilr |
|
186 |
|
|
|
!=== INTEGER INTERFACES |
|
187 |
|
|
188 |
SUBROUTINE getinis (TARGET,ret_val) |
CHARACTER(LEN=*) :: MY_TARGET |
|
!--------------------------------------------------------------------- |
|
|
!- Get a interer scalar. We first check if we find it |
|
|
!- in the database and if not we get it from the run.def |
|
|
|
|
|
!- getini1d and getini2d are written on the same pattern |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: TARGET |
|
189 |
INTEGER :: ret_val |
INTEGER :: ret_val |
190 |
|
|
191 |
INTEGER,DIMENSION(1) :: tmp_ret_val |
INTEGER, DIMENSION(1) :: tmp_ret_val |
192 |
INTEGER :: target_sig, pos, status=0, fileorig |
INTEGER :: target_sig, pos, status=0, fileorig |
193 |
!--------------------------------------------------------------------- |
|
194 |
|
|
195 |
! Compute the signature of the target |
! Compute the signature of the target |
196 |
|
|
197 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
198 |
|
|
199 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
200 |
|
|
201 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
202 |
|
|
203 |
tmp_ret_val(1) = ret_val |
tmp_ret_val(1) = ret_val |
204 |
|
|
205 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
206 |
!-- Ge the information out of the file |
! Ge the information out of the file |
207 |
CALL getfili (TARGET,status,fileorig,tmp_ret_val) |
CALL getfili(MY_TARGET, status, fileorig, tmp_ret_val) |
208 |
!-- Put the data into the database |
! Put the data into the database |
209 |
CALL getdbwi (TARGET,target_sig,status,fileorig,1,tmp_ret_val) |
CALL getdbwi(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val) |
210 |
ELSE |
ELSE |
211 |
!-- Get the value out of the database |
! Get the value out of the database |
212 |
CALL getdbri (pos,1,TARGET,tmp_ret_val) |
CALL getdbri (pos, 1, MY_TARGET, tmp_ret_val) |
213 |
ENDIF |
ENDIF |
214 |
ret_val = tmp_ret_val(1) |
ret_val = tmp_ret_val(1) |
215 |
!--------------------- |
|
216 |
END SUBROUTINE getinis |
END SUBROUTINE getinis |
217 |
|
|
218 |
!**************************** |
!**************************** |
219 |
|
|
220 |
SUBROUTINE getini1d (TARGET,ret_val) |
SUBROUTINE getini1d(MY_TARGET, ret_val) |
221 |
!--------------------------------------------------------------------- |
|
222 |
!- See getinis for details. It is the same thing but for a vector |
! See getinis for details. It is the same thing but for a vector |
223 |
!--------------------------------------------------------------------- |
|
224 |
|
|
225 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
226 |
INTEGER,DIMENSION(:) :: ret_val |
INTEGER, DIMENSION(:) :: ret_val |
227 |
|
|
228 |
INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
229 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
230 |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
231 |
!--------------------------------------------------------------------- |
|
232 |
|
|
233 |
! Compute the signature of the target |
! Compute the signature of the target |
234 |
|
|
235 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
236 |
|
|
237 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
238 |
|
|
239 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
240 |
|
|
241 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
242 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
243 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
247 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
248 |
ENDIF |
ENDIF |
249 |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
250 |
|
|
251 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
252 |
!-- Ge the information out of the file |
! Ge the information out of the file |
253 |
CALL getfili (TARGET,status,fileorig,tmp_ret_val) |
CALL getfili(MY_TARGET, status, fileorig, tmp_ret_val) |
254 |
!-- Put the data into the database |
! Put the data into the database |
255 |
CALL getdbwi & |
CALL getdbwi & |
256 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
257 |
ELSE |
ELSE |
258 |
!-- Get the value out of the database |
! Get the value out of the database |
259 |
CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbri (pos, size_of_in, MY_TARGET, tmp_ret_val) |
260 |
ENDIF |
ENDIF |
261 |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
262 |
!---------------------- |
|
263 |
END SUBROUTINE getini1d |
END SUBROUTINE getini1d |
264 |
|
|
265 |
!**************************** |
!**************************** |
266 |
|
|
267 |
SUBROUTINE getini2d (TARGET,ret_val) |
SUBROUTINE getini2d(MY_TARGET, ret_val) |
268 |
!--------------------------------------------------------------------- |
|
269 |
!- See getinis for details. It is the same thing but for a matrix |
! See getinis for details. It is the same thing but for a matrix |
270 |
!--------------------------------------------------------------------- |
|
271 |
|
|
272 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
273 |
INTEGER,DIMENSION(:,:) :: ret_val |
INTEGER, DIMENSION(:, :) :: ret_val |
274 |
|
|
275 |
INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
276 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
277 |
INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig |
INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig |
278 |
INTEGER :: jl, jj, ji |
INTEGER :: jl, jj, ji |
279 |
!--------------------------------------------------------------------- |
|
280 |
|
|
281 |
! Compute the signature of the target |
! Compute the signature of the target |
282 |
|
|
283 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
284 |
|
|
285 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
286 |
|
|
287 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
288 |
|
|
289 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
290 |
size_1 = SIZE(ret_val,1) |
size_1 = SIZE(ret_val, 1) |
291 |
size_2 = SIZE(ret_val,2) |
size_2 = SIZE(ret_val, 2) |
292 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
293 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
294 |
ELSE IF (size_of_in > tmp_ret_size) THEN |
ELSE IF (size_of_in > tmp_ret_size) THEN |
296 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
297 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
298 |
ENDIF |
ENDIF |
299 |
|
|
300 |
jl=0 |
jl=0 |
301 |
DO jj=1,size_2 |
DO jj=1, size_2 |
302 |
DO ji=1,size_1 |
DO ji=1, size_1 |
303 |
jl=jl+1 |
jl=jl+1 |
304 |
tmp_ret_val(jl) = ret_val(ji,jj) |
tmp_ret_val(jl) = ret_val(ji, jj) |
305 |
ENDDO |
ENDDO |
306 |
ENDDO |
ENDDO |
307 |
|
|
308 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
309 |
!-- Ge the information out of the file |
! Ge the information out of the file |
310 |
CALL getfili (TARGET,status,fileorig,tmp_ret_val) |
CALL getfili(MY_TARGET, status, fileorig, tmp_ret_val) |
311 |
!-- Put the data into the database |
! Put the data into the database |
312 |
CALL getdbwi & |
CALL getdbwi & |
313 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
314 |
ELSE |
ELSE |
315 |
!-- Get the value out of the database |
! Get the value out of the database |
316 |
CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbri (pos, size_of_in, MY_TARGET, tmp_ret_val) |
317 |
ENDIF |
ENDIF |
318 |
|
|
319 |
jl=0 |
jl=0 |
320 |
DO jj=1,size_2 |
DO jj=1, size_2 |
321 |
DO ji=1,size_1 |
DO ji=1, size_1 |
322 |
jl=jl+1 |
jl=jl+1 |
323 |
ret_val(ji,jj) = tmp_ret_val(jl) |
ret_val(ji, jj) = tmp_ret_val(jl) |
324 |
ENDDO |
ENDDO |
325 |
ENDDO |
ENDDO |
326 |
!---------------------- |
|
327 |
END SUBROUTINE getini2d |
END SUBROUTINE getini2d |
328 |
|
|
329 |
!**************************** |
!**************************** |
330 |
|
|
|
SUBROUTINE getfili (TARGET,status,fileorig,ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Subroutine that will extract from the file the values |
|
|
!- attributed to the keyword target |
|
|
|
|
|
!- INTEGER |
|
|
!- ------- |
|
|
|
|
|
!- target : in : CHARACTER(LEN=*) target for which we will |
|
|
!- look in the file |
|
|
!- status : out : INTEGER tells us from where we obtained the data |
|
|
!- fileorig : out : The index of the file from which the key comes |
|
|
!- ret_val : out : INTEGER(nb_to_ret) values read |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: TARGET |
|
|
INTEGER :: status, fileorig |
|
|
INTEGER :: ret_val(:) |
|
|
|
|
|
INTEGER :: nb_to_ret |
|
|
INTEGER :: it, pos, len_str, status_cnt |
|
|
CHARACTER(LEN=3) :: cnt, chlen |
|
|
CHARACTER(LEN=10) :: fmt |
|
|
CHARACTER(LEN=30) :: full_target |
|
|
CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp |
|
|
INTEGER :: full_target_sig |
|
|
INTEGER :: compvalue |
|
|
|
|
|
INTEGER,SAVE :: max_len = 0 |
|
|
LOGICAL,SAVE,ALLOCATABLE :: found(:) |
|
|
LOGICAL :: def_beha |
|
|
LOGICAL :: compressed = .FALSE. |
|
|
!--------------------------------------------------------------------- |
|
|
nb_to_ret = SIZE(ret_val) |
|
|
CALL getin_read |
|
|
|
|
|
! Get the variables and memory we need |
|
|
|
|
|
IF (max_len == 0) THEN |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
IF (max_len < nb_to_ret) THEN |
|
|
DEALLOCATE(found) |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
found(:) = .FALSE. |
|
|
|
|
|
! See what we find in the files read |
|
|
|
|
|
DO it=1,nb_to_ret |
|
|
!--- |
|
|
!-- First try the target as it is |
|
|
!--- |
|
|
full_target = TARGET(1:len_TRIM(target)) |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
!--- |
|
|
!-- Another try |
|
|
!--- |
|
|
IF (pos < 0) THEN |
|
|
WRITE(cnt,'(I3.3)') it |
|
|
full_target = TARGET(1:len_TRIM(target))//'__'//cnt |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
ENDIF |
|
|
!--- |
|
|
!-- A priori we dont know from which file the target could come. |
|
|
!-- Thus by default we attribute it to the first file : |
|
|
!--- |
|
|
fileorig = 1 |
|
|
|
|
|
IF (pos > 0) THEN |
|
|
!----- |
|
|
found(it) = .TRUE. |
|
|
fileorig = fromfile(pos) |
|
|
!----- |
|
|
!---- DECODE |
|
|
!---- |
|
|
str_READ = TRIM(ADJUSTL(fichier(pos))) |
|
|
str_READ_lower = str_READ |
|
|
CALL strlowercase (str_READ_lower) |
|
|
!----- |
|
|
IF ( ( (INDEX(str_READ_lower,'def') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 3) ) & |
|
|
& .OR.( (INDEX(str_READ_lower,'default') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN |
|
|
def_beha = .TRUE. |
|
|
ELSE |
|
|
def_beha = .FALSE. |
|
|
len_str = LEN_TRIM(str_READ) |
|
|
WRITE(chlen,'(I3.3)') len_str |
|
|
fmt = '(I'//chlen//')' |
|
|
READ(str_READ,fmt) ret_val(it) |
|
|
ENDIF |
|
|
!----- |
|
|
targetsiglist(pos) = -1 |
|
|
!----- |
|
|
!---- Is this the value of a compressed field ? |
|
|
!----- |
|
|
IF (compline(pos) > 0) THEN |
|
|
IF (compline(pos) == nb_to_ret) THEN |
|
|
compressed = .TRUE. |
|
|
compvalue = ret_val(it) |
|
|
ELSE |
|
|
WRITE(*,*) 'WARNING from getfilr' |
|
|
WRITE(*,*) 'For key ',TRIM(TARGET), & |
|
|
& ' we have a compressed field but which does not have the right size.' |
|
|
WRITE(*,*) 'We will try to fix that ' |
|
|
compressed = .TRUE. |
|
|
compvalue = ret_val(it) |
|
|
ENDIF |
|
|
ENDIF |
|
|
ELSE |
|
|
found(it) = .FALSE. |
|
|
ENDIF |
|
|
ENDDO |
|
|
|
|
|
! If this is a compressed field then we will uncompress it |
|
|
|
|
|
IF (compressed) THEN |
|
|
DO it=1,nb_to_ret |
|
|
IF (.NOT. found(it)) THEN |
|
|
ret_val(it) = compvalue |
|
|
found(it) = .TRUE. |
|
|
ENDIF |
|
|
ENDDO |
|
|
ENDIF |
|
|
|
|
|
! Now we get the status for what we found |
|
|
|
|
|
IF (def_beha) THEN |
|
|
status = 2 |
|
|
WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) |
|
|
ELSE |
|
|
status_cnt = 0 |
|
|
DO it=1,nb_to_ret |
|
|
IF (.NOT. found(it)) THEN |
|
|
status_cnt = status_cnt+1 |
|
|
IF (nb_to_ret > 1) THEN |
|
|
WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it |
|
|
ELSE |
|
|
str_tmp = TRIM(TARGET) |
|
|
ENDIF |
|
|
WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) |
|
|
ENDIF |
|
|
ENDDO |
|
|
!--- |
|
|
IF (status_cnt == 0) THEN |
|
|
status = 1 |
|
|
ELSE IF (status_cnt == nb_to_ret) THEN |
|
|
status = 2 |
|
|
ELSE |
|
|
status = 3 |
|
|
ENDIF |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getfili |
|
|
|
|
331 |
!=== CHARACTER INTERFACES |
!=== CHARACTER INTERFACES |
332 |
|
|
333 |
SUBROUTINE getincs (TARGET,ret_val) |
SUBROUTINE getincs(MY_TARGET, ret_val) |
334 |
!--------------------------------------------------------------------- |
|
335 |
!- Get a CHARACTER scalar. We first check if we find it |
! Get a CHARACTER scalar. We first check if we find it |
336 |
!- in the database and if not we get it from the run.def |
! in the database and if not we get it from the run.def |
337 |
|
|
338 |
!- getinc1d and getinc2d are written on the same pattern |
! getinc1d and getinc2d are written on the same pattern |
339 |
!--------------------------------------------------------------------- |
|
340 |
|
|
341 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
342 |
CHARACTER(LEN=*) :: ret_val |
CHARACTER(LEN=*) :: ret_val |
343 |
|
|
344 |
CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val |
CHARACTER(LEN=100), DIMENSION(1) :: tmp_ret_val |
345 |
INTEGER :: target_sig, pos, status=0, fileorig |
INTEGER :: target_sig, pos, status=0, fileorig |
346 |
!--------------------------------------------------------------------- |
|
347 |
|
|
348 |
! Compute the signature of the target |
! Compute the signature of the target |
349 |
|
|
350 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
351 |
|
|
352 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
353 |
|
|
354 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
355 |
|
|
356 |
tmp_ret_val(1) = ret_val |
tmp_ret_val(1) = ret_val |
357 |
|
|
358 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
359 |
!-- Ge the information out of the file |
! Ge the information out of the file |
360 |
CALL getfilc (TARGET,status,fileorig,tmp_ret_val) |
CALL getfilc(MY_TARGET, status, fileorig, tmp_ret_val) |
361 |
!-- Put the data into the database |
! Put the data into the database |
362 |
CALL getdbwc (TARGET,target_sig,status,fileorig,1,tmp_ret_val) |
CALL getdbwc(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val) |
363 |
ELSE |
ELSE |
364 |
!-- Get the value out of the database |
! Get the value out of the database |
365 |
CALL getdbrc (pos,1,TARGET,tmp_ret_val) |
CALL getdbrc (pos, 1, MY_TARGET, tmp_ret_val) |
366 |
ENDIF |
ENDIF |
367 |
ret_val = tmp_ret_val(1) |
ret_val = tmp_ret_val(1) |
368 |
!--------------------- |
|
369 |
END SUBROUTINE getincs |
END SUBROUTINE getincs |
370 |
|
|
371 |
!**************************** |
!**************************** |
372 |
|
|
373 |
SUBROUTINE getinc1d (TARGET,ret_val) |
SUBROUTINE getinc1d(MY_TARGET, ret_val) |
374 |
!--------------------------------------------------------------------- |
|
375 |
!- See getincs for details. It is the same thing but for a vector |
! See getincs for details. It is the same thing but for a vector |
376 |
!--------------------------------------------------------------------- |
|
377 |
|
|
378 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
379 |
CHARACTER(LEN=*),DIMENSION(:) :: ret_val |
CHARACTER(LEN=*), DIMENSION(:) :: ret_val |
380 |
|
|
381 |
CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
CHARACTER(LEN=100), DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
382 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
383 |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
384 |
!--------------------------------------------------------------------- |
|
385 |
|
|
386 |
! Compute the signature of the target |
! Compute the signature of the target |
387 |
|
|
388 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
389 |
|
|
390 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
391 |
|
|
392 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
393 |
|
|
394 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
395 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
396 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
400 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
401 |
ENDIF |
ENDIF |
402 |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
403 |
|
|
404 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
405 |
!-- Ge the information out of the file |
! Ge the information out of the file |
406 |
CALL getfilc (TARGET,status,fileorig,tmp_ret_val) |
CALL getfilc(MY_TARGET, status, fileorig, tmp_ret_val) |
407 |
!-- Put the data into the database |
! Put the data into the database |
408 |
CALL getdbwc & |
CALL getdbwc & |
409 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
410 |
ELSE |
ELSE |
411 |
!-- Get the value out of the database |
! Get the value out of the database |
412 |
CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbrc (pos, size_of_in, MY_TARGET, tmp_ret_val) |
413 |
ENDIF |
ENDIF |
414 |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
415 |
!---------------------- |
|
416 |
END SUBROUTINE getinc1d |
END SUBROUTINE getinc1d |
417 |
|
|
418 |
!**************************** |
!**************************** |
419 |
|
|
420 |
SUBROUTINE getinc2d (TARGET,ret_val) |
SUBROUTINE getinc2d(MY_TARGET, ret_val) |
421 |
!--------------------------------------------------------------------- |
|
422 |
!- See getincs for details. It is the same thing but for a matrix |
! See getincs for details. It is the same thing but for a matrix |
423 |
!--------------------------------------------------------------------- |
|
424 |
|
|
425 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
426 |
CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val |
CHARACTER(LEN=*), DIMENSION(:, :) :: ret_val |
427 |
|
|
428 |
CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
CHARACTER(LEN=100), DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
429 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
430 |
INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig |
INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig |
431 |
INTEGER :: jl,jj,ji |
INTEGER :: jl, jj, ji |
432 |
!--------------------------------------------------------------------- |
|
433 |
|
|
434 |
! Compute the signature of the target |
! Compute the signature of the target |
435 |
|
|
436 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
437 |
|
|
438 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
439 |
|
|
440 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
441 |
|
|
442 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
443 |
size_1 = SIZE(ret_val,1) |
size_1 = SIZE(ret_val, 1) |
444 |
size_2 = SIZE(ret_val,2) |
size_2 = SIZE(ret_val, 2) |
445 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
446 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
447 |
ELSE IF (size_of_in > tmp_ret_size) THEN |
ELSE IF (size_of_in > tmp_ret_size) THEN |
449 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
450 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
451 |
ENDIF |
ENDIF |
452 |
|
|
453 |
jl=0 |
jl=0 |
454 |
DO jj=1,size_2 |
DO jj=1, size_2 |
455 |
DO ji=1,size_1 |
DO ji=1, size_1 |
456 |
jl=jl+1 |
jl=jl+1 |
457 |
tmp_ret_val(jl) = ret_val(ji,jj) |
tmp_ret_val(jl) = ret_val(ji, jj) |
458 |
ENDDO |
ENDDO |
459 |
ENDDO |
ENDDO |
460 |
|
|
461 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
462 |
!-- Ge the information out of the file |
! Ge the information out of the file |
463 |
CALL getfilc (TARGET,status,fileorig,tmp_ret_val) |
CALL getfilc(MY_TARGET, status, fileorig, tmp_ret_val) |
464 |
!-- Put the data into the database |
! Put the data into the database |
465 |
CALL getdbwc & |
CALL getdbwc & |
466 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
467 |
ELSE |
ELSE |
468 |
!-- Get the value out of the database |
! Get the value out of the database |
469 |
CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbrc (pos, size_of_in, MY_TARGET, tmp_ret_val) |
470 |
ENDIF |
ENDIF |
471 |
|
|
472 |
jl=0 |
jl=0 |
473 |
DO jj=1,size_2 |
DO jj=1, size_2 |
474 |
DO ji=1,size_1 |
DO ji=1, size_1 |
475 |
jl=jl+1 |
jl=jl+1 |
476 |
ret_val(ji,jj) = tmp_ret_val(jl) |
ret_val(ji, jj) = tmp_ret_val(jl) |
477 |
ENDDO |
ENDDO |
478 |
ENDDO |
ENDDO |
479 |
!---------------------- |
|
480 |
END SUBROUTINE getinc2d |
END SUBROUTINE getinc2d |
481 |
|
|
482 |
!**************************** |
!**************************** |
483 |
|
|
|
SUBROUTINE getfilc (TARGET,status,fileorig,ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Subroutine that will extract from the file the values |
|
|
!- attributed to the keyword target |
|
|
|
|
|
!- CHARACTER |
|
|
!- --------- |
|
|
|
|
|
!- target : in : CHARACTER(LEN=*) target for which we will |
|
|
!- look in the file |
|
|
!- status : out : INTEGER tells us from where we obtained the data |
|
|
!- fileorig : out : The index of the file from which the key comes |
|
|
!- ret_val : out : CHARACTER(nb_to_ret) values read |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
|
|
|
CHARACTER(LEN=*) :: TARGET |
|
|
INTEGER :: status, fileorig |
|
|
CHARACTER(LEN=*),DIMENSION(:) :: ret_val |
|
|
|
|
|
INTEGER :: nb_to_ret |
|
|
INTEGER :: it, pos, len_str, status_cnt |
|
|
CHARACTER(LEN=3) :: cnt |
|
|
CHARACTER(LEN=30) :: full_target |
|
|
CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp |
|
|
INTEGER :: full_target_sig |
|
|
|
|
|
INTEGER,SAVE :: max_len = 0 |
|
|
LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found |
|
|
LOGICAL :: def_beha |
|
|
!--------------------------------------------------------------------- |
|
|
nb_to_ret = SIZE(ret_val) |
|
|
CALL getin_read |
|
|
|
|
|
! Get the variables and memory we need |
|
|
|
|
|
IF (max_len == 0) THEN |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
IF (max_len < nb_to_ret) THEN |
|
|
DEALLOCATE(found) |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
found(:) = .FALSE. |
|
|
|
|
|
! See what we find in the files read |
|
|
|
|
|
DO it=1,nb_to_ret |
|
|
!--- |
|
|
!-- First try the target as it is |
|
|
full_target = TARGET(1:len_TRIM(target)) |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
!--- |
|
|
!-- Another try |
|
|
!--- |
|
|
IF (pos < 0) THEN |
|
|
WRITE(cnt,'(I3.3)') it |
|
|
full_target = TARGET(1:len_TRIM(target))//'__'//cnt |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
ENDIF |
|
|
!--- |
|
|
!-- A priori we dont know from which file the target could come. |
|
|
!-- Thus by default we attribute it to the first file : |
|
|
!--- |
|
|
fileorig = 1 |
|
|
!--- |
|
|
IF (pos > 0) THEN |
|
|
!----- |
|
|
found(it) = .TRUE. |
|
|
fileorig = fromfile(pos) |
|
|
!----- |
|
|
!---- DECODE |
|
|
!----- |
|
|
str_READ = TRIM(ADJUSTL(fichier(pos))) |
|
|
str_READ_lower = str_READ |
|
|
CALL strlowercase (str_READ_lower) |
|
|
!----- |
|
|
IF ( ( (INDEX(str_READ_lower,'def') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 3) ) & |
|
|
& .OR.( (INDEX(str_READ_lower,'default') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN |
|
|
def_beha = .TRUE. |
|
|
ELSE |
|
|
def_beha = .FALSE. |
|
|
len_str = LEN_TRIM(str_READ) |
|
|
ret_val(it) = str_READ(1:len_str) |
|
|
ENDIF |
|
|
!----- |
|
|
targetsiglist(pos) = -1 |
|
|
!----- |
|
|
ELSE |
|
|
found(it) = .FALSE. |
|
|
ENDIF |
|
|
ENDDO |
|
|
|
|
|
! Now we get the status for what we found |
|
|
|
|
|
IF (def_beha) THEN |
|
|
status = 2 |
|
|
WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) |
|
|
ELSE |
|
|
status_cnt = 0 |
|
|
DO it=1,nb_to_ret |
|
|
IF (.NOT. found(it)) THEN |
|
|
status_cnt = status_cnt+1 |
|
|
IF (nb_to_ret > 1) THEN |
|
|
WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it |
|
|
ELSE |
|
|
str_tmp = TARGET(1:len_TRIM(target)) |
|
|
ENDIF |
|
|
WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) |
|
|
ENDIF |
|
|
ENDDO |
|
|
|
|
|
IF (status_cnt == 0) THEN |
|
|
status = 1 |
|
|
ELSE IF (status_cnt == nb_to_ret) THEN |
|
|
status = 2 |
|
|
ELSE |
|
|
status = 3 |
|
|
ENDIF |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getfilc |
|
|
|
|
484 |
!=== LOGICAL INTERFACES |
!=== LOGICAL INTERFACES |
485 |
|
|
486 |
SUBROUTINE getinls (TARGET,ret_val) |
SUBROUTINE getinls(MY_TARGET, ret_val) |
487 |
!--------------------------------------------------------------------- |
|
488 |
!- Get a logical scalar. We first check if we find it |
! Get a logical scalar. We first check if we find it |
489 |
!- in the database and if not we get it from the run.def |
! in the database and if not we get it from the run.def |
490 |
|
|
491 |
!- getinl1d and getinl2d are written on the same pattern |
! getinl1d and getinl2d are written on the same pattern |
492 |
!--------------------------------------------------------------------- |
|
493 |
|
|
494 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
495 |
LOGICAL :: ret_val |
LOGICAL :: ret_val |
496 |
|
|
497 |
LOGICAL,DIMENSION(1) :: tmp_ret_val |
LOGICAL, DIMENSION(1) :: tmp_ret_val |
498 |
INTEGER :: target_sig, pos, status=0, fileorig |
INTEGER :: target_sig, pos, status=0, fileorig |
499 |
!--------------------------------------------------------------------- |
|
500 |
|
|
501 |
! Compute the signature of the target |
! Compute the signature of the target |
502 |
|
|
503 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
504 |
|
|
505 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
506 |
|
|
507 |
if (nb_keys > 0) then |
if (nb_keys > 0) then |
508 |
CALL find_sig(nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig(nb_keys, keystr, my_target, keysig, target_sig, pos) |
509 |
else |
else |
510 |
pos = -1 |
pos = -1 |
511 |
end if |
end if |
512 |
|
|
513 |
tmp_ret_val(1) = ret_val |
tmp_ret_val(1) = ret_val |
514 |
|
|
515 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
516 |
!-- Ge the information out of the file |
! Ge the information out of the file |
517 |
CALL getfill (TARGET,status,fileorig,tmp_ret_val) |
CALL getfill(MY_TARGET, status, fileorig, tmp_ret_val) |
518 |
!-- Put the data into the database |
! Put the data into the database |
519 |
CALL getdbwl (TARGET,target_sig,status,fileorig,1,tmp_ret_val) |
CALL getdbwl(MY_TARGET, target_sig, status, fileorig, 1, tmp_ret_val) |
520 |
ELSE |
ELSE |
521 |
!-- Get the value out of the database |
! Get the value out of the database |
522 |
CALL getdbrl (pos,1,TARGET,tmp_ret_val) |
CALL getdbrl (pos, 1, MY_TARGET, tmp_ret_val) |
523 |
ENDIF |
ENDIF |
524 |
ret_val = tmp_ret_val(1) |
ret_val = tmp_ret_val(1) |
525 |
!--------------------- |
|
526 |
END SUBROUTINE getinls |
END SUBROUTINE getinls |
527 |
|
|
528 |
!**************************** |
!**************************** |
529 |
|
|
530 |
SUBROUTINE getinl1d (TARGET,ret_val) |
SUBROUTINE getinl1d(MY_TARGET, ret_val) |
531 |
!--------------------------------------------------------------------- |
|
532 |
!- See getinls for details. It is the same thing but for a vector |
! See getinls for details. It is the same thing but for a vector |
533 |
!--------------------------------------------------------------------- |
|
534 |
|
|
535 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
536 |
LOGICAL,DIMENSION(:) :: ret_val |
LOGICAL, DIMENSION(:) :: ret_val |
537 |
|
|
538 |
LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
LOGICAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
539 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
540 |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
INTEGER :: target_sig, pos, size_of_in, status=0, fileorig |
541 |
!--------------------------------------------------------------------- |
|
542 |
|
|
543 |
! Compute the signature of the target |
! Compute the signature of the target |
544 |
|
|
545 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
546 |
|
|
547 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
548 |
|
|
549 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
550 |
|
|
551 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
552 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
553 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
557 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
558 |
ENDIF |
ENDIF |
559 |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) |
560 |
|
|
561 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
562 |
!-- Ge the information out of the file |
! Ge the information out of the file |
563 |
CALL getfill (TARGET,status,fileorig,tmp_ret_val) |
CALL getfill(MY_TARGET, status, fileorig, tmp_ret_val) |
564 |
!-- Put the data into the database |
! Put the data into the database |
565 |
CALL getdbwl & |
CALL getdbwl & |
566 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
567 |
ELSE |
ELSE |
568 |
!-- Get the value out of the database |
! Get the value out of the database |
569 |
CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbrl (pos, size_of_in, MY_TARGET, tmp_ret_val) |
570 |
ENDIF |
ENDIF |
571 |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) |
572 |
!---------------------- |
|
573 |
END SUBROUTINE getinl1d |
END SUBROUTINE getinl1d |
574 |
|
|
575 |
!**************************** |
!**************************** |
576 |
|
|
577 |
SUBROUTINE getinl2d (TARGET,ret_val) |
SUBROUTINE getinl2d(MY_TARGET, ret_val) |
578 |
!--------------------------------------------------------------------- |
|
579 |
!- See getinls for details. It is the same thing but for a matrix |
! See getinls for details. It is the same thing but for a matrix |
580 |
!--------------------------------------------------------------------- |
|
581 |
|
|
582 |
CHARACTER(LEN=*) :: TARGET |
CHARACTER(LEN=*) :: MY_TARGET |
583 |
LOGICAL,DIMENSION(:,:) :: ret_val |
LOGICAL, DIMENSION(:, :) :: ret_val |
584 |
|
|
585 |
LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val |
LOGICAL, DIMENSION(:), ALLOCATABLE, SAVE :: tmp_ret_val |
586 |
INTEGER,SAVE :: tmp_ret_size = 0 |
INTEGER, SAVE :: tmp_ret_size = 0 |
587 |
INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig |
INTEGER :: target_sig, pos, size_of_in, size_1, size_2, status=0, fileorig |
588 |
INTEGER :: jl,jj,ji |
INTEGER :: jl, jj, ji |
589 |
!--------------------------------------------------------------------- |
|
590 |
|
|
591 |
! Compute the signature of the target |
! Compute the signature of the target |
592 |
|
|
593 |
CALL gensig (TARGET,target_sig) |
CALL gensig(MY_TARGET, target_sig) |
594 |
|
|
595 |
! Do we have this target in our database ? |
! Do we have this target in our database ? |
596 |
|
|
597 |
CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) |
CALL find_sig (nb_keys, keystr, my_target, keysig, target_sig, pos) |
598 |
|
|
599 |
size_of_in = SIZE(ret_val) |
size_of_in = SIZE(ret_val) |
600 |
size_1 = SIZE(ret_val,1) |
size_1 = SIZE(ret_val, 1) |
601 |
size_2 = SIZE(ret_val,2) |
size_2 = SIZE(ret_val, 2) |
602 |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
IF (.NOT.ALLOCATED(tmp_ret_val)) THEN |
603 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
604 |
ELSE IF (size_of_in > tmp_ret_size) THEN |
ELSE IF (size_of_in > tmp_ret_size) THEN |
606 |
ALLOCATE (tmp_ret_val(size_of_in)) |
ALLOCATE (tmp_ret_val(size_of_in)) |
607 |
tmp_ret_size = size_of_in |
tmp_ret_size = size_of_in |
608 |
ENDIF |
ENDIF |
609 |
|
|
610 |
jl=0 |
jl=0 |
611 |
DO jj=1,size_2 |
DO jj=1, size_2 |
612 |
DO ji=1,size_1 |
DO ji=1, size_1 |
613 |
jl=jl+1 |
jl=jl+1 |
614 |
tmp_ret_val(jl) = ret_val(ji,jj) |
tmp_ret_val(jl) = ret_val(ji, jj) |
615 |
ENDDO |
ENDDO |
616 |
ENDDO |
ENDDO |
617 |
|
|
618 |
IF (pos < 0) THEN |
IF (pos < 0) THEN |
619 |
!-- Ge the information out of the file |
! Ge the information out of the file |
620 |
CALL getfill (TARGET,status,fileorig,tmp_ret_val) |
CALL getfill(MY_TARGET, status, fileorig, tmp_ret_val) |
621 |
!-- Put the data into the database |
! Put the data into the database |
622 |
CALL getdbwl & |
CALL getdbwl & |
623 |
& (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
& (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val) |
624 |
ELSE |
ELSE |
625 |
!-- Get the value out of the database |
! Get the value out of the database |
626 |
CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val) |
CALL getdbrl (pos, size_of_in, MY_TARGET, tmp_ret_val) |
627 |
ENDIF |
ENDIF |
628 |
|
|
629 |
jl=0 |
jl=0 |
630 |
DO jj=1,size_2 |
DO jj=1, size_2 |
631 |
DO ji=1,size_1 |
DO ji=1, size_1 |
632 |
jl=jl+1 |
jl=jl+1 |
633 |
ret_val(ji,jj) = tmp_ret_val(jl) |
ret_val(ji, jj) = tmp_ret_val(jl) |
|
ENDDO |
|
|
ENDDO |
|
|
!---------------------- |
|
|
END SUBROUTINE getinl2d |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getfill (TARGET,status,fileorig,ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Subroutine that will extract from the file the values |
|
|
!- attributed to the keyword target |
|
|
|
|
|
!- LOGICAL |
|
|
!- ------- |
|
|
|
|
|
!- target : in : CHARACTER(LEN=*) target for which we will |
|
|
!- look in the file |
|
|
!- status : out : INTEGER tells us from where we obtained the data |
|
|
!- fileorig : out : The index of the file from which the key comes |
|
|
!- ret_val : out : LOGICAL(nb_to_ret) values read |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: TARGET |
|
|
INTEGER :: status, fileorig |
|
|
LOGICAL,DIMENSION(:) :: ret_val |
|
|
|
|
|
INTEGER :: nb_to_ret |
|
|
INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, status_cnt |
|
|
CHARACTER(LEN=3) :: cnt |
|
|
CHARACTER(LEN=30) :: full_target |
|
|
CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp |
|
|
INTEGER :: full_target_sig |
|
|
|
|
|
INTEGER,SAVE :: max_len = 0 |
|
|
LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found |
|
|
LOGICAL :: def_beha |
|
|
!--------------------------------------------------------------------- |
|
|
nb_to_ret = SIZE(ret_val) |
|
|
CALL getin_read |
|
|
|
|
|
! Get the variables and memory we need |
|
|
|
|
|
IF (max_len == 0) THEN |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
IF (max_len < nb_to_ret) THEN |
|
|
DEALLOCATE(found) |
|
|
ALLOCATE(found(nb_to_ret)) |
|
|
max_len = nb_to_ret |
|
|
ENDIF |
|
|
found(:) = .FALSE. |
|
|
|
|
|
! See what we find in the files read |
|
|
|
|
|
DO it=1,nb_to_ret |
|
|
!--- |
|
|
!-- First try the target as it is |
|
|
!--- |
|
|
full_target = TARGET(1:len_TRIM(target)) |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
!--- |
|
|
!-- Another try |
|
|
!--- |
|
|
IF (pos < 0) THEN |
|
|
WRITE(cnt,'(I3.3)') it |
|
|
full_target = TARGET(1:len_TRIM(target))//'__'//cnt |
|
|
CALL gensig (full_target,full_target_sig) |
|
|
CALL find_sig (nb_lines,targetlist,full_target, & |
|
|
& targetsiglist,full_target_sig,pos) |
|
|
ENDIF |
|
|
!--- |
|
|
!-- A priori we dont know from which file the target could come. |
|
|
!-- Thus by default we attribute it to the first file : |
|
|
!--- |
|
|
fileorig = 1 |
|
|
!--- |
|
|
IF (pos > 0) THEN |
|
|
!----- |
|
|
found(it) = .TRUE. |
|
|
fileorig = fromfile(pos) |
|
|
!----- |
|
|
!---- DECODE |
|
|
!----- |
|
|
str_READ = TRIM(ADJUSTL(fichier(pos))) |
|
|
str_READ_lower = str_READ |
|
|
CALL strlowercase (str_READ_lower) |
|
|
!----- |
|
|
IF ( ( (INDEX(str_READ_lower,'def') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 3) ) & |
|
|
& .OR.( (INDEX(str_READ_lower,'default') == 1) & |
|
|
& .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN |
|
|
def_beha = .TRUE. |
|
|
ELSE |
|
|
def_beha = .FALSE. |
|
|
len_str = LEN_TRIM(str_READ) |
|
|
ipos_tr = -1 |
|
|
ipos_fl = -1 |
|
|
!------- |
|
|
ipos_tr = MAX(INDEX(str_READ,'tru'),INDEX(str_READ,'TRU'), & |
|
|
& INDEX(str_READ,'y'),INDEX(str_READ,'Y')) |
|
|
ipos_fl = MAX(INDEX(str_READ,'fal'),INDEX(str_READ,'FAL'), & |
|
|
& INDEX(str_READ,'n'),INDEX(str_READ,'N')) |
|
|
!------- |
|
|
IF (ipos_tr > 0) THEN |
|
|
ret_val(it) = .TRUE. |
|
|
ELSE IF (ipos_fl > 0) THEN |
|
|
ret_val(it) = .FALSE. |
|
|
ELSE |
|
|
WRITE(*,*) "ERROR : getfill : TARGET ", & |
|
|
& TRIM(TARGET)," is not of logical value" |
|
|
STOP 'getinl' |
|
|
ENDIF |
|
|
ENDIF |
|
|
!----- |
|
|
targetsiglist(pos) = -1 |
|
|
!----- |
|
|
ELSE |
|
|
|
|
|
found(it) = .FALSE. |
|
|
|
|
|
ENDIF |
|
|
|
|
|
ENDDO |
|
|
|
|
|
! Now we get the status for what we found |
|
|
|
|
|
IF (def_beha) THEN |
|
|
status = 2 |
|
|
WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) |
|
|
ELSE |
|
|
status_cnt = 0 |
|
|
DO it=1,nb_to_ret |
|
|
IF (.NOT. found(it)) THEN |
|
|
status_cnt = status_cnt+1 |
|
|
IF (nb_to_ret > 1) THEN |
|
|
WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it |
|
|
ELSE |
|
|
str_tmp = TRIM(TARGET) |
|
|
ENDIF |
|
|
WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) |
|
|
ENDIF |
|
|
ENDDO |
|
|
!--- |
|
|
IF (status_cnt == 0) THEN |
|
|
status = 1 |
|
|
ELSE IF (status_cnt == nb_to_ret) THEN |
|
|
status = 2 |
|
|
ELSE |
|
|
status = 3 |
|
|
ENDIF |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getfill |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getin_read |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER,SAVE :: allread=0 |
|
|
INTEGER,SAVE :: current |
|
|
!--------------------------------------------------------------------- |
|
|
IF (allread == 0) THEN |
|
|
!-- Allocate a first set of memory. |
|
|
CALL getin_allockeys |
|
|
CALL getin_allocmem (1,0) |
|
|
CALL getin_allocmem (2,0) |
|
|
CALL getin_allocmem (3,0) |
|
|
CALL getin_allocmem (4,0) |
|
|
!-- Start with reading the files |
|
|
nbfiles = 1 |
|
|
filelist(1) = 'run.def' |
|
|
current = 1 |
|
|
nb_lines = 0 |
|
|
!-- |
|
|
DO WHILE (current <= nbfiles) |
|
|
CALL getin_readdef (current) |
|
|
current = current+1 |
|
|
ENDDO |
|
|
allread = 1 |
|
|
CALL getin_checkcohe () |
|
|
ENDIF |
|
|
!------------------------ |
|
|
END SUBROUTINE getin_read |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getin_readdef(current) |
|
|
!--------------------------------------------------------------------- |
|
|
!- This subroutine will read the files and only keep the |
|
|
!- the relevant information. The information is kept as it |
|
|
!- found in the file. The data will be analysed later. |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER :: current |
|
|
|
|
|
CHARACTER(LEN=100) :: READ_str, NEW_str, new_key, last_key, key_str |
|
|
CHARACTER(LEN=3) :: cnt |
|
|
INTEGER :: nb_lastkey |
|
|
|
|
|
INTEGER :: eof, ptn, len_str, i, it, iund |
|
|
LOGICAL :: check = .FALSE. |
|
|
!--------------------------------------------------------------------- |
|
|
eof = 0 |
|
|
ptn = 1 |
|
|
nb_lastkey = 0 |
|
|
|
|
|
IF (check) THEN |
|
|
WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) |
|
|
ENDIF |
|
|
|
|
|
OPEN (22,file=filelist(current),ERR=9997,STATUS="OLD") |
|
|
|
|
|
DO WHILE (eof /= 1) |
|
|
!--- |
|
|
CALL getin_skipafew (22,READ_str,eof,nb_lastkey) |
|
|
len_str = LEN_TRIM(READ_str) |
|
|
ptn = INDEX(READ_str,'=') |
|
|
!--- |
|
|
IF (ptn > 0) THEN |
|
|
!---- Get the target |
|
|
key_str = TRIM(ADJUSTL(READ_str(1:ptn-1))) |
|
|
!---- Make sure that if a vector keyword has the right length |
|
|
iund = INDEX(key_str,'__') |
|
|
IF (iund > 0) THEN |
|
|
SELECTCASE( len_trim(key_str)-iund ) |
|
|
CASE(2) |
|
|
READ(key_str(iund+2:len_trim(key_str)),'(I1)') it |
|
|
CASE(3) |
|
|
READ(key_str(iund+2:len_trim(key_str)),'(I2)') it |
|
|
CASE(4) |
|
|
READ(key_str(iund+2:len_trim(key_str)),'(I3)') it |
|
|
CASE DEFAULT |
|
|
it = -1 |
|
|
END SELECT |
|
|
IF (it > 0) THEN |
|
|
WRITE(cnt,'(I3.3)') it |
|
|
key_str = key_str(1:iund+1)//cnt |
|
|
ELSE |
|
|
WRITE(*,*) & |
|
|
& 'getin_readdef : A very strange key has just been found' |
|
|
WRITE(*,*) 'getin_readdef : ',key_str(1:len_TRIM(key_str)) |
|
|
STOP 'getin_readdef' |
|
|
ENDIF |
|
|
ENDIF |
|
|
!---- Prepare the content |
|
|
NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str))) |
|
|
CALL nocomma (NEW_str) |
|
|
CALL cmpblank (NEW_str) |
|
|
NEW_str = TRIM(ADJUSTL(NEW_str)) |
|
|
IF (check) THEN |
|
|
WRITE(*,*) & |
|
|
& '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) |
|
|
ENDIF |
|
|
!---- Decypher the content of NEW_str |
|
|
|
|
|
!---- This has to be a new key word, thus : |
|
|
nb_lastkey = 0 |
|
|
!---- |
|
|
CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) |
|
|
!---- |
|
|
ELSE IF (len_str > 0) THEN |
|
|
!---- Prepare the key if we have an old one to which |
|
|
!---- we will add the line just read |
|
|
IF (nb_lastkey > 0) THEN |
|
|
iund = INDEX(last_key,'__') |
|
|
IF (iund > 0) THEN |
|
|
!-------- We only continue a keyword, thus it is easy |
|
|
key_str = last_key(1:iund-1) |
|
|
ELSE |
|
|
IF (nb_lastkey /= 1) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_readdef : An error has occured. We can not have a scalar' |
|
|
WRITE(*,*) 'getin_readdef : keywod and a vector content' |
|
|
STOP 'getin_readdef' |
|
|
ENDIF |
|
|
!-------- The last keyword needs to be transformed into a vector. |
|
|
targetlist(nb_lines) = & |
|
|
& last_key(1:MIN(len_trim(last_key),30))//'__001' |
|
|
CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) |
|
|
key_str = last_key(1:len_TRIM(last_key)) |
|
|
ENDIF |
|
|
ENDIF |
|
|
!---- Prepare the content |
|
|
NEW_str = TRIM(ADJUSTL(READ_str(1:len_str))) |
|
|
CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) |
|
|
ELSE |
|
|
!---- If we have an empty line the the keyword finishes |
|
|
nb_lastkey = 0 |
|
|
IF (check) THEN |
|
|
WRITE(*,*) 'getin_readdef : Have found an emtpy line ' |
|
|
ENDIF |
|
|
ENDIF |
|
|
ENDDO |
|
|
|
|
|
CLOSE(22) |
|
|
|
|
|
IF (check) THEN |
|
|
OPEN (22,file='run.def.test') |
|
|
DO i=1,nb_lines |
|
|
WRITE(22,*) targetlist(i)," : ",fichier(i) |
|
|
ENDDO |
|
|
CLOSE(22) |
|
|
ENDIF |
|
|
|
|
|
RETURN |
|
|
|
|
|
9997 WRITE(*,*) "getin_readdef : Could not open file ", & |
|
|
& TRIM(filelist(current)) |
|
|
!--------------------------- |
|
|
END SUBROUTINE getin_readdef |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey) |
|
|
!--------------------------------------------------------------------- |
|
|
!- This subroutine is going to decypher the line. |
|
|
!- It essentialy checks how many items are included and |
|
|
!- it they can be attached to a key. |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
! ARGUMENTS |
|
|
|
|
|
INTEGER :: current, nb_lastkey |
|
|
CHARACTER(LEN=*) :: key_str, NEW_str, last_key |
|
|
|
|
|
! LOCAL |
|
|
|
|
|
INTEGER :: len_str, blk, nbve, starpos |
|
|
CHARACTER(LEN=100) :: tmp_str, new_key, mult |
|
|
CHARACTER(LEN=3) :: cnt, chlen |
|
|
CHARACTER(LEN=10) :: fmt |
|
|
!--------------------------------------------------------------------- |
|
|
len_str = LEN_TRIM(NEW_str) |
|
|
blk = INDEX(NEW_str(1:len_str),' ') |
|
|
tmp_str = NEW_str(1:len_str) |
|
|
|
|
|
! If the key is a new file then we take it up. Else |
|
|
! we save the line and go on. |
|
|
|
|
|
IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN |
|
|
DO WHILE (blk > 0) |
|
|
IF (nbfiles+1 > max_files) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Too many files to include' |
|
|
STOP 'getin_readdef' |
|
|
ENDIF |
|
|
!----- |
|
|
nbfiles = nbfiles+1 |
|
|
filelist(nbfiles) = tmp_str(1:blk) |
|
|
!----- |
|
|
tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) |
|
|
blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ') |
|
634 |
ENDDO |
ENDDO |
|
!--- |
|
|
IF (nbfiles+1 > max_files) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Too many files to include' |
|
|
STOP 'getin_readdef' |
|
|
ENDIF |
|
|
!--- |
|
|
nbfiles = nbfiles+1 |
|
|
filelist(nbfiles) = TRIM(ADJUSTL(tmp_str)) |
|
|
!--- |
|
|
last_key = 'INCLUDEDEF' |
|
|
nb_lastkey = 1 |
|
|
ELSE |
|
|
|
|
|
!-- We are working on a new line of input |
|
|
|
|
|
nb_lines = nb_lines+1 |
|
|
IF (nb_lines > max_lines) THEN |
|
|
WRITE(*,*) & |
|
|
& 'Too many line in the run.def files. You need to increase' |
|
|
WRITE(*,*) 'the parameter max_lines in the module getincom.' |
|
|
STOP 'getin_decrypt' |
|
|
ENDIF |
|
|
|
|
|
!-- First we solve the issue of conpressed information. Once |
|
|
!-- this is done all line can be handled in the same way. |
|
|
|
|
|
starpos = INDEX(NEW_str(1:len_str),'*') |
|
|
IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') & |
|
|
& .AND.(tmp_str(1:1) /= "'") ) THEN |
|
|
!----- |
|
|
IF (INDEX(key_str(1:len_TRIM(key_str)),'__') > 0) THEN |
|
|
WRITE(*,*) 'ERROR : getin_decrypt' |
|
|
WRITE(*,*) & |
|
|
& 'We can not have a compressed field of values for in a' |
|
|
WRITE(*,*) & |
|
|
& 'vector notation. If a target is of the type TARGET__1' |
|
|
WRITE(*,*) 'then only a scalar value is allowed' |
|
|
WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str)) |
|
|
STOP 'getin_decrypt' |
|
|
ENDIF |
|
|
|
|
|
!---- Read the multiplied |
|
|
|
|
|
mult = TRIM(ADJUSTL(NEW_str(1:starpos-1))) |
|
|
!---- Construct the new string and its parameters |
|
|
NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str))) |
|
|
len_str = LEN_TRIM(NEW_str) |
|
|
blk = INDEX(NEW_str(1:len_str),' ') |
|
|
IF (blk > 1) THEN |
|
|
WRITE(*,*) & |
|
|
& 'This is a strange behavior of getin_decrypt you could report' |
|
|
ENDIF |
|
|
WRITE(chlen,'(I3.3)') LEN_TRIM(mult) |
|
|
fmt = '(I'//chlen//')' |
|
|
READ(mult,fmt) compline(nb_lines) |
|
|
!--- |
|
|
ELSE |
|
|
compline(nb_lines) = -1 |
|
|
ENDIF |
|
|
|
|
|
!-- If there is no space wthin the line then the target is a scalar |
|
|
!-- or the element of a properly written vector. |
|
|
!-- (ie of the type TARGET__1) |
|
|
|
|
|
IF ( (blk <= 1) & |
|
|
& .OR.(tmp_str(1:1) == '"') & |
|
|
& .OR.(tmp_str(1:1) == "'") ) THEN |
|
|
|
|
|
IF (nb_lastkey == 0) THEN |
|
|
!------ Save info of current keyword as a scalar |
|
|
!------ if it is not a continuation |
|
|
targetlist(nb_lines) = key_str(1:MIN(len_trim(key_str),30)) |
|
|
last_key = key_str(1:MIN(len_trim(key_str),30)) |
|
|
nb_lastkey = 1 |
|
|
ELSE |
|
|
!------ We are continuing a vector so the keyword needs |
|
|
!------ to get the underscores |
|
|
WRITE(cnt,'(I3.3)') nb_lastkey+1 |
|
|
targetlist(nb_lines) = & |
|
|
& key_str(1:MIN(len_trim(key_str),25))//'__'//cnt |
|
|
last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt |
|
|
nb_lastkey = nb_lastkey+1 |
|
|
ENDIF |
|
|
!----- |
|
|
CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) |
|
|
fichier(nb_lines) = NEW_str(1:len_str) |
|
|
fromfile(nb_lines) = current |
|
|
ELSE |
|
|
|
|
|
!---- If there are blanks whithin the line then we are dealing |
|
|
!---- with a vector and we need to split it in many entries |
|
|
!---- with the TRAGET__1 notation. |
|
|
!---- |
|
|
!---- Test if the targer is not already a vector target ! |
|
|
|
|
|
IF (INDEX(TRIM(key_str),'__') > 0) THEN |
|
|
WRITE(*,*) 'ERROR : getin_decrypt' |
|
|
WRITE(*,*) 'We have found a mixed vector notation' |
|
|
WRITE(*,*) 'If a target is of the type TARGET__1' |
|
|
WRITE(*,*) 'then only a scalar value is allowed' |
|
|
WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str)) |
|
|
STOP 'getin_decrypt' |
|
|
ENDIF |
|
|
|
|
|
nbve = nb_lastkey |
|
|
nbve = nbve+1 |
|
|
WRITE(cnt,'(I3.3)') nbve |
|
|
|
|
|
DO WHILE (blk > 0) |
|
|
|
|
|
!------ Save the content of target__nbve |
|
|
|
|
|
fichier(nb_lines) = tmp_str(1:blk) |
|
|
new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt |
|
|
targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30)) |
|
|
CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) |
|
|
fromfile(nb_lines) = current |
|
|
|
|
|
tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) |
|
|
blk = INDEX(TRIM(tmp_str),' ') |
|
|
|
|
|
nb_lines = nb_lines+1 |
|
|
IF (nb_lines > max_lines) THEN |
|
|
WRITE(*,*) & |
|
|
& 'Too many line in the run.def files. You need to increase' |
|
|
WRITE(*,*) 'the parameter max_lines in the module getincom.' |
|
|
STOP 'getin_decrypt' |
|
|
ENDIF |
|
|
nbve = nbve+1 |
|
|
WRITE(cnt,'(I3.3)') nbve |
|
|
|
|
|
ENDDO |
|
|
|
|
|
!---- Save the content of the last target |
|
|
|
|
|
fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) |
|
|
new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt |
|
|
targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30)) |
|
|
CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) |
|
|
fromfile(nb_lines) = current |
|
|
|
|
|
last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt |
|
|
nb_lastkey = nbve |
|
|
|
|
|
ENDIF |
|
|
|
|
|
ENDIF |
|
|
!--------------------------- |
|
|
END SUBROUTINE getin_decrypt |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getin_checkcohe () |
|
|
!--------------------------------------------------------------------- |
|
|
!- This subroutine checks for redundancies. |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
! Arguments |
|
|
|
|
|
|
|
|
! LOCAL |
|
|
|
|
|
INTEGER :: line,i,sig |
|
|
INTEGER :: found |
|
|
CHARACTER(LEN=30) :: str |
|
|
!--------------------------------------------------------------------- |
|
|
DO line=1,nb_lines-1 |
|
|
|
|
|
CALL find_sig & |
|
|
& (nb_lines-line,targetlist(line+1:nb_lines),targetlist(line), & |
|
|
& targetsiglist(line+1:nb_lines),targetsiglist(line),found) |
|
|
!--- |
|
|
!-- IF we have found it we have a problem to solve. |
|
|
!--- |
|
|
IF (found > 0) THEN |
|
|
WRITE(*,*) 'COUNT : ', & |
|
|
& COUNT(ABS(targetsiglist(line+1:nb_lines)-targetsiglist(line)) < 1) |
|
|
!----- |
|
|
WRITE(*,*) & |
|
|
& 'getin_checkcohe : Found a problem on key ',targetlist(line) |
|
|
WRITE(*,*) & |
|
|
& 'getin_checkcohe : The following values were encoutered :' |
|
|
WRITE(*,*) & |
|
|
& ' ',TRIM(targetlist(line)), & |
|
|
& targetsiglist(line),' == ',fichier(line) |
|
|
WRITE(*,*) & |
|
|
& ' ',TRIM(targetlist(line+found)), & |
|
|
& targetsiglist(line+found),' == ',fichier(line+found) |
|
|
WRITE(*,*) & |
|
|
& 'getin_checkcohe : We will keep only the last value' |
|
|
!----- |
|
|
targetsiglist(line) = 1 |
|
|
ENDIF |
|
635 |
ENDDO |
ENDDO |
|
|
|
|
END SUBROUTINE getin_checkcohe |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey) |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER :: unit, eof, nb_lastkey |
|
|
CHARACTER(LEN=100) :: dummy |
|
|
CHARACTER(LEN=100) :: out_string |
|
|
CHARACTER(LEN=1) :: first |
|
|
!--------------------------------------------------------------------- |
|
|
first="#" |
|
|
eof = 0 |
|
|
out_string = " " |
|
|
|
|
|
DO WHILE (first == "#") |
|
|
READ (unit,'(a100)',ERR=9998,END=7778) dummy |
|
|
dummy = TRIM(ADJUSTL(dummy)) |
|
|
first=dummy(1:1) |
|
|
IF (first == "#") THEN |
|
|
nb_lastkey = 0 |
|
|
ENDIF |
|
|
ENDDO |
|
|
out_string=dummy |
|
|
|
|
|
RETURN |
|
|
|
|
|
9998 WRITE(*,*) " GETIN_SKIPAFEW : Error while reading file " |
|
|
STOP 'getin_skipafew' |
|
|
|
|
|
7778 eof = 1 |
|
|
!---------------------------- |
|
|
END SUBROUTINE getin_skipafew |
|
|
|
|
|
!=== INTEGER database INTERFACE |
|
|
|
|
|
SUBROUTINE getdbwi & |
|
|
& (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Write the INTEGER data into the data base |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: target |
|
|
INTEGER :: target_sig, status, fileorig, size_of_in |
|
|
INTEGER,DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
! First check if we have sufficiant space for the new key |
|
|
|
|
|
IF (nb_keys+1 > keymemsize) THEN |
|
|
CALL getin_allockeys () |
|
|
ENDIF |
|
|
|
|
|
! Fill out the items of the data base |
|
|
|
|
|
nb_keys = nb_keys+1 |
|
|
keysig(nb_keys) = target_sig |
|
|
keystr(nb_keys) = target(1:MIN(len_trim(target),30)) |
|
|
keystatus(nb_keys) = status |
|
|
keytype(nb_keys) = 1 |
|
|
keyfromfile(nb_keys) = fileorig |
|
|
|
|
|
! Can we compress the data base entry ? |
|
|
|
|
|
IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) & |
|
|
& .AND.(size_of_in > compress_lim)) THEN |
|
|
keymemstart(nb_keys) = intmempos+1 |
|
|
keycompress(nb_keys) = size_of_in |
|
|
keymemlen(nb_keys) = 1 |
|
|
ELSE |
|
|
keymemstart(nb_keys) = intmempos+1 |
|
|
keycompress(nb_keys) = -1 |
|
|
keymemlen(nb_keys) = size_of_in |
|
|
ENDIF |
|
|
|
|
|
! Before writing the actual size lets see if we have the space |
|
|
|
|
|
IF (keymemstart(nb_keys)+keymemlen(nb_keys) > intmemsize) THEN |
|
|
CALL getin_allocmem (1,keymemlen(nb_keys)) |
|
|
ENDIF |
|
|
|
|
|
intmem(keymemstart(nb_keys): & |
|
|
& keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & |
|
|
& tmp_ret_val(1:keymemlen(nb_keys)) |
|
|
intmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbwi |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getdbri (pos,size_of_in,target,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Read the required variables in the database for INTEGERS |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER :: pos, size_of_in |
|
|
CHARACTER(LEN=*) :: target |
|
|
INTEGER,DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
IF (keytype(pos) /= 1) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target |
|
|
STOP 'getdbri' |
|
|
ENDIF |
|
|
|
|
|
IF (keycompress(pos) > 0) THEN |
|
|
IF ( keycompress(pos) /= size_of_in .OR. keymemlen(pos) /= 1 ) THEN |
|
|
WRITE(*,*) & |
|
|
& 'FATAL ERROR : Wrong compression length for keyword ',target |
|
|
STOP 'getdbri' |
|
|
ELSE |
|
|
tmp_ret_val(1:size_of_in) = intmem(keymemstart(pos)) |
|
|
ENDIF |
|
|
ELSE |
|
|
IF (keymemlen(pos) /= size_of_in) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target |
|
|
STOP 'getdbri' |
|
|
ELSE |
|
|
tmp_ret_val(1:size_of_in) = & |
|
|
& intmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) |
|
|
ENDIF |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbri |
|
|
|
|
|
!=== REAL database INTERFACE |
|
|
|
|
|
SUBROUTINE getdbwr & |
|
|
& (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Write the REAL data into the data base |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: target |
|
|
INTEGER :: target_sig, status, fileorig, size_of_in |
|
|
REAL,DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
! First check if we have sufficiant space for the new key |
|
|
|
|
|
IF (nb_keys+1 > keymemsize) THEN |
|
|
CALL getin_allockeys () |
|
|
ENDIF |
|
|
|
|
|
! Fill out the items of the data base |
|
|
|
|
|
nb_keys = nb_keys+1 |
|
|
keysig(nb_keys) = target_sig |
|
|
keystr(nb_keys) = target(1:MIN(len_trim(target),30)) |
|
|
keystatus(nb_keys) = status |
|
|
keytype(nb_keys) = 2 |
|
|
keyfromfile(nb_keys) = fileorig |
|
|
|
|
|
! Can we compress the data base entry ? |
|
|
|
|
|
IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) & |
|
|
& .AND.(size_of_in > compress_lim)) THEN |
|
|
keymemstart(nb_keys) = realmempos+1 |
|
|
keycompress(nb_keys) = size_of_in |
|
|
keymemlen(nb_keys) = 1 |
|
|
ELSE |
|
|
keymemstart(nb_keys) = realmempos+1 |
|
|
keycompress(nb_keys) = -1 |
|
|
keymemlen(nb_keys) = size_of_in |
|
|
ENDIF |
|
|
|
|
|
! Before writing the actual size lets see if we have the space |
|
|
|
|
|
IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN |
|
|
CALL getin_allocmem (2,keymemlen(nb_keys)) |
|
|
ENDIF |
|
|
|
|
|
realmem(keymemstart(nb_keys): & |
|
|
& keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & |
|
|
& tmp_ret_val(1:keymemlen(nb_keys)) |
|
|
realmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbwr |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getdbrr (pos,size_of_in,target,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Read the required variables in the database for REALS |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER :: pos, size_of_in |
|
|
CHARACTER(LEN=*) :: target |
|
|
REAL,DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
IF (keytype(pos) /= 2) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target |
|
|
STOP 'getdbrr' |
|
|
ENDIF |
|
|
|
|
|
IF (keycompress(pos) > 0) THEN |
|
|
IF ( (keycompress(pos) /= size_of_in) & |
|
|
& .OR.(keymemlen(pos) /= 1) ) THEN |
|
|
WRITE(*,*) & |
|
|
& 'FATAL ERROR : Wrong compression length for keyword ',target |
|
|
STOP 'getdbrr' |
|
|
ELSE |
|
|
tmp_ret_val(1:size_of_in) = realmem(keymemstart(pos)) |
|
|
ENDIF |
|
|
ELSE |
|
|
IF (keymemlen(pos) /= size_of_in) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target |
|
|
STOP 'getdbrr' |
|
|
ELSE |
|
|
tmp_ret_val(1:size_of_in) = & |
|
|
& realmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) |
|
|
ENDIF |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbrr |
|
|
|
|
|
!=== CHARACTER database INTERFACE |
|
636 |
|
|
637 |
SUBROUTINE getdbwc & |
END SUBROUTINE getinl2d |
|
& (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Write the CHARACTER data into the data base |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: target |
|
|
INTEGER :: target_sig,status,fileorig,size_of_in |
|
|
CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
! First check if we have sufficiant space for the new key |
|
|
|
|
|
IF (nb_keys+1 > keymemsize) THEN |
|
|
CALL getin_allockeys () |
|
|
ENDIF |
|
|
|
|
|
! Fill out the items of the data base |
|
|
|
|
|
nb_keys = nb_keys+1 |
|
|
keysig(nb_keys) = target_sig |
|
|
keystr(nb_keys) = target(1:MIN(len_trim(target),30)) |
|
|
keystatus(nb_keys) = status |
|
|
keytype(nb_keys) = 3 |
|
|
keyfromfile(nb_keys) = fileorig |
|
|
keymemstart(nb_keys) = charmempos+1 |
|
|
keymemlen(nb_keys) = size_of_in |
|
|
|
|
|
! Before writing the actual size lets see if we have the space |
|
|
|
|
|
IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN |
|
|
CALL getin_allocmem (3,keymemlen(nb_keys)) |
|
|
ENDIF |
|
|
|
|
|
charmem(keymemstart(nb_keys): & |
|
|
& keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & |
|
|
& tmp_ret_val(1:keymemlen(nb_keys)) |
|
|
charmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbwc |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getdbrc(pos,size_of_in,target,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Read the required variables in the database for CHARACTER |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER :: pos, size_of_in |
|
|
CHARACTER(LEN=*) :: target |
|
|
CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
IF (keytype(pos) /= 3) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target |
|
|
STOP 'getdbrc' |
|
|
ENDIF |
|
|
|
|
|
IF (keymemlen(pos) /= size_of_in) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target |
|
|
STOP 'getdbrc' |
|
|
ELSE |
|
|
tmp_ret_val(1:size_of_in) = & |
|
|
& charmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbrc |
|
|
|
|
|
!=== LOGICAL database INTERFACE |
|
|
|
|
|
SUBROUTINE getdbwl & |
|
|
& (target,target_sig,status,fileorig,size_of_in,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Write the LOGICAL data into the data base |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
CHARACTER(LEN=*) :: target |
|
|
INTEGER :: target_sig, status, fileorig, size_of_in |
|
|
LOGICAL,DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
! First check if we have sufficiant space for the new key |
|
|
|
|
|
IF (nb_keys+1 > keymemsize) THEN |
|
|
CALL getin_allockeys () |
|
|
ENDIF |
|
|
|
|
|
! Fill out the items of the data base |
|
|
|
|
|
nb_keys = nb_keys+1 |
|
|
keysig(nb_keys) = target_sig |
|
|
keystr(nb_keys) = target(1:MIN(len_trim(target),30)) |
|
|
keystatus(nb_keys) = status |
|
|
keytype(nb_keys) = 4 |
|
|
keyfromfile(nb_keys) = fileorig |
|
|
keymemstart(nb_keys) = logicmempos+1 |
|
|
keymemlen(nb_keys) = size_of_in |
|
|
|
|
|
! Before writing the actual size lets see if we have the space |
|
|
|
|
|
IF (keymemstart(nb_keys)+keymemlen(nb_keys) > logicmemsize) THEN |
|
|
CALL getin_allocmem (4,keymemlen(nb_keys)) |
|
|
ENDIF |
|
|
|
|
|
logicmem(keymemstart(nb_keys): & |
|
|
& keymemstart(nb_keys)+keymemlen(nb_keys)-1) = & |
|
|
& tmp_ret_val(1:keymemlen(nb_keys)) |
|
|
logicmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1 |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbwl |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getdbrl(pos,size_of_in,target,tmp_ret_val) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Read the required variables in the database for LOGICALS |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER :: pos, size_of_in |
|
|
CHARACTER(LEN=*) :: target |
|
|
LOGICAL,DIMENSION(:) :: tmp_ret_val |
|
|
!--------------------------------------------------------------------- |
|
|
IF (keytype(pos) /= 4) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target |
|
|
STOP 'getdbrl' |
|
|
ENDIF |
|
|
|
|
|
IF (keymemlen(pos) /= size_of_in) THEN |
|
|
WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target |
|
|
STOP 'getdbrl' |
|
|
ELSE |
|
|
tmp_ret_val(1:size_of_in) = & |
|
|
& logicmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) |
|
|
ENDIF |
|
|
!--------------------- |
|
|
END SUBROUTINE getdbrl |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getin_allockeys |
|
|
|
|
|
INTEGER,ALLOCATABLE :: tmp_int(:) |
|
|
CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:) |
|
|
|
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
!!print *, "Call sequence information: getin_allockeys" |
|
|
! Either nothing exists in these arrays and it is easy to do |
|
|
|
|
|
IF (keymemsize == 0) THEN |
|
|
ALLOCATE(keysig(memslabs)) |
|
|
ALLOCATE(keystr(memslabs)) |
|
|
ALLOCATE(keystatus(memslabs)) |
|
|
ALLOCATE(keytype(memslabs)) |
|
|
ALLOCATE(keycompress(memslabs)) |
|
|
ALLOCATE(keyfromfile(memslabs)) |
|
|
ALLOCATE(keymemstart(memslabs)) |
|
|
ALLOCATE(keymemlen(memslabs)) |
|
|
nb_keys = 0 |
|
|
keymemsize = memslabs |
|
|
keycompress(:) = -1 |
|
|
ELSE |
|
|
!-- There is something already in the memory, |
|
|
!-- we need to transfer and reallocate. |
|
|
ALLOCATE(tmp_str(keymemsize)) |
|
|
|
|
|
ALLOCATE(tmp_int(keymemsize)) |
|
|
tmp_int(1:keymemsize) = keysig(1:keymemsize) |
|
|
|
|
|
DEALLOCATE(keysig) |
|
|
ALLOCATE(keysig(keymemsize+memslabs)) |
|
|
keysig(1:keymemsize) = tmp_int(1:keymemsize) |
|
|
|
|
|
tmp_str(1:keymemsize) = keystr(1:keymemsize) |
|
|
DEALLOCATE(keystr) |
|
|
ALLOCATE(keystr(keymemsize+memslabs)) |
|
|
keystr(1:keymemsize) = tmp_str(1:keymemsize) |
|
|
|
|
|
tmp_int(1:keymemsize) = keystatus(1:keymemsize) |
|
|
DEALLOCATE(keystatus) |
|
|
ALLOCATE(keystatus(keymemsize+memslabs)) |
|
|
keystatus(1:keymemsize) = tmp_int(1:keymemsize) |
|
|
|
|
|
tmp_int(1:keymemsize) = keytype(1:keymemsize) |
|
|
DEALLOCATE(keytype) |
|
|
ALLOCATE(keytype(keymemsize+memslabs)) |
|
|
keytype(1:keymemsize) = tmp_int(1:keymemsize) |
|
|
|
|
|
tmp_int(1:keymemsize) = keycompress(1:keymemsize) |
|
|
DEALLOCATE(keycompress) |
|
|
ALLOCATE(keycompress(keymemsize+memslabs)) |
|
|
keycompress(:) = -1 |
|
|
keycompress(1:keymemsize) = tmp_int(1:keymemsize) |
|
|
|
|
|
tmp_int(1:keymemsize) = keyfromfile(1:keymemsize) |
|
|
DEALLOCATE(keyfromfile) |
|
|
ALLOCATE(keyfromfile(keymemsize+memslabs)) |
|
|
keyfromfile(1:keymemsize) = tmp_int(1:keymemsize) |
|
|
|
|
|
tmp_int(1:keymemsize) = keymemstart(1:keymemsize) |
|
|
DEALLOCATE(keymemstart) |
|
|
ALLOCATE(keymemstart(keymemsize+memslabs)) |
|
|
keymemstart(1:keymemsize) = tmp_int(1:keymemsize) |
|
|
|
|
|
tmp_int(1:keymemsize) = keymemlen(1:keymemsize) |
|
|
DEALLOCATE(keymemlen) |
|
|
ALLOCATE(keymemlen(keymemsize+memslabs)) |
|
|
keymemlen(1:keymemsize) = tmp_int(1:keymemsize) |
|
|
|
|
|
keymemsize = keymemsize+memslabs |
|
|
|
|
|
DEALLOCATE(tmp_int) |
|
|
DEALLOCATE(tmp_str) |
|
|
ENDIF |
|
|
|
|
|
END SUBROUTINE getin_allockeys |
|
|
|
|
|
!**************************** |
|
|
|
|
|
SUBROUTINE getin_allocmem (type,len_wanted) |
|
|
!--------------------------------------------------------------------- |
|
|
!- Allocate the memory of the data base for all 4 types of memory |
|
|
|
|
|
!- 1 = INTEGER |
|
|
!- 2 = REAL |
|
|
!- 3 = CHAR |
|
|
!- 4 = LOGICAL |
|
|
!--------------------------------------------------------------------- |
|
|
|
|
|
INTEGER :: type, len_wanted |
|
|
|
|
|
INTEGER,ALLOCATABLE :: tmp_int(:) |
|
|
CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) |
|
|
REAL,ALLOCATABLE :: tmp_real(:) |
|
|
LOGICAL,ALLOCATABLE :: tmp_logic(:) |
|
|
INTEGER :: ier |
|
|
!--------------------------------------------------------------------- |
|
|
SELECT CASE (type) |
|
|
CASE(1) |
|
|
IF (intmemsize == 0) THEN |
|
|
ALLOCATE(intmem(memslabs),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate db-memory intmem to ', & |
|
|
& memslabs |
|
|
STOP |
|
|
ENDIF |
|
|
intmemsize=memslabs |
|
|
ELSE |
|
|
ALLOCATE(tmp_int(intmemsize),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate tmp_int to ', & |
|
|
& intmemsize |
|
|
STOP |
|
|
ENDIF |
|
|
tmp_int(1:intmemsize) = intmem(1:intmemsize) |
|
|
DEALLOCATE(intmem) |
|
|
ALLOCATE(intmem(intmemsize+MAX(memslabs,len_wanted)),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to re-allocate db-memory intmem to ', & |
|
|
& intmemsize+MAX(memslabs,len_wanted) |
|
|
STOP |
|
|
ENDIF |
|
|
intmem(1:intmemsize) = tmp_int(1:intmemsize) |
|
|
intmemsize = intmemsize+MAX(memslabs,len_wanted) |
|
|
DEALLOCATE(tmp_int) |
|
|
ENDIF |
|
|
CASE(2) |
|
|
IF (realmemsize == 0) THEN |
|
|
ALLOCATE(realmem(memslabs),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate db-memory realmem to ', & |
|
|
& memslabs |
|
|
STOP |
|
|
ENDIF |
|
|
realmemsize = memslabs |
|
|
ELSE |
|
|
ALLOCATE(tmp_real(realmemsize),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate tmp_real to ', & |
|
|
& realmemsize |
|
|
STOP |
|
|
ENDIF |
|
|
tmp_real(1:realmemsize) = realmem(1:realmemsize) |
|
|
DEALLOCATE(realmem) |
|
|
ALLOCATE(realmem(realmemsize+MAX(memslabs,len_wanted)),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to re-allocate db-memory realmem to ', & |
|
|
& realmemsize+MAX(memslabs,len_wanted) |
|
|
STOP |
|
|
ENDIF |
|
|
realmem(1:realmemsize) = tmp_real(1:realmemsize) |
|
|
realmemsize = realmemsize+MAX(memslabs,len_wanted) |
|
|
DEALLOCATE(tmp_real) |
|
|
ENDIF |
|
|
CASE(3) |
|
|
IF (charmemsize == 0) THEN |
|
|
ALLOCATE(charmem(memslabs),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate db-memory charmem to ', & |
|
|
& memslabs |
|
|
STOP |
|
|
ENDIF |
|
|
charmemsize = memslabs |
|
|
ELSE |
|
|
ALLOCATE(tmp_char(charmemsize),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate tmp_char to ', & |
|
|
& charmemsize |
|
|
STOP |
|
|
ENDIF |
|
|
tmp_char(1:charmemsize) = charmem(1:charmemsize) |
|
|
DEALLOCATE(charmem) |
|
|
ALLOCATE(charmem(charmemsize+MAX(memslabs,len_wanted)),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to re-allocate db-memory charmem to ', & |
|
|
& charmemsize+MAX(memslabs,len_wanted) |
|
|
STOP |
|
|
ENDIF |
|
|
charmem(1:charmemsize) = tmp_char(1:charmemsize) |
|
|
charmemsize = charmemsize+MAX(memslabs,len_wanted) |
|
|
DEALLOCATE(tmp_char) |
|
|
ENDIF |
|
|
CASE(4) |
|
|
IF (logicmemsize == 0) THEN |
|
|
ALLOCATE(logicmem(memslabs),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate db-memory logicmem to ', & |
|
|
& memslabs |
|
|
STOP |
|
|
ENDIF |
|
|
logicmemsize = memslabs |
|
|
ELSE |
|
|
ALLOCATE(tmp_logic(logicmemsize),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to allocate tmp_logic to ', & |
|
|
& logicmemsize |
|
|
STOP |
|
|
ENDIF |
|
|
tmp_logic(1:logicmemsize) = logicmem(1:logicmemsize) |
|
|
DEALLOCATE(logicmem) |
|
|
ALLOCATE(logicmem(logicmemsize+MAX(memslabs,len_wanted)),stat=ier) |
|
|
IF (ier /= 0) THEN |
|
|
WRITE(*,*) & |
|
|
& 'getin_allocmem : Unable to re-allocate db-memory logicmem to ', & |
|
|
& logicmemsize+MAX(memslabs,len_wanted) |
|
|
STOP |
|
|
ENDIF |
|
|
logicmem(1:logicmemsize) = tmp_logic(1:logicmemsize) |
|
|
logicmemsize = logicmemsize+MAX(memslabs,len_wanted) |
|
|
DEALLOCATE(tmp_logic) |
|
|
ENDIF |
|
|
CASE DEFAULT |
|
|
WRITE(*,*) 'getin_allocmem : Unknown type : ',type |
|
|
STOP |
|
|
END SELECT |
|
|
!---------------------------- |
|
|
END SUBROUTINE getin_allocmem |
|
638 |
|
|
639 |
END MODULE getincom |
END MODULE getincom |