Context Navigation

module_generic.f90 @ 1664

Last change on this file since 1664 was 1664, checked in by lfita, 7 years ago
Making use of the new module `module_NCgeneric.f90'
File size: 11.8 KB

Line
1	MODULE module_generic
2	! Module with generic functions
3
4	!!!!!!! Subroutines/Functions
5	! freeunit: provides the number of a free unit in which open a file
6	! GetInNamelist: Subroutine to get a paramter from a namelistfile
7	! index_list_coordsI: Function to provide the index of a given coordinate within a list of integer coordinates
8	! Index1DArrayI: Function to provide the first index of a given value inside a 1D integer array
9	! Index1DArrayR: Function to provide the first index of a given value inside a 1D real array
10	! Index1DArrayR_K: Function to provide the first index of a given value inside a 1D real(r_k) array
11	! Index2DArrayR: Function to provide the first index of a given value inside a 2D real array
12	! Index2DArrayR_K: Function to provide the first index of a given value inside a 2D real(r_k) array
13	! Nvalues_2DArrayI: Number of different values of a 2D integer array
14	! mat2DPosition: Function to provide the i, j indices of a given value inside a 2D matrix
15	! RangeI: Function to provide a range of d1 values from 'iniv' to 'endv', of integer values in a vector
16	! RangeR: Function to provide a range of d1 values from 'iniv' to 'endv', of real values in a vector
17	! RangeR_K: Function to provide a range of d1 from 'iniv' to 'endv', of real(r_k) values in a vector
18	! stoprun: Subroutine to stop running and print a message
19
20	USE module_definitions
21	USE module_basic
22
23	CONTAINS
24
25	SUBROUTINE Nvalues_2DArrayI(dx, dy, dxy, mat2DI, Nvals, vals)
26	! Subroutine to give the number of different values of a 2D integer array
27
28	IMPLICIT NONE
29
30	INTEGER, INTENT(in) :: dx, dy, dxy
31	INTEGER, DIMENSION(dx,dy), INTENT(in) :: mat2DI
32	INTEGER, INTENT(out) :: Nvals
33	INTEGER, DIMENSION(dxy), INTENT(out) :: vals
34
35	! Local
36	INTEGER :: i, j, ij
37
38	!!!!!!! Variables
39	! dx, dy: size of the 2D space
40	! mat2DI: 2D integer matrix
41	! Nvals: number of different values
42	! vals: vector with the different values
43
44	fname = 'Nvalues_2DArrayI'
45
46	vals = 0
47
48	Nvals = 1
49	vals(1) = mat2DI(1,1)
50	DO i=1,dx
51	DO j=1,dy
52	IF (Index1DArrayI(vals, Nvals, mat2DI(i,j)) == -1) THEN
53	Nvals = Nvals + 1
54	vals(Nvals) = mat2DI(i,j)
55	END IF
56	END DO
57	END DO
58
59	RETURN
60
61	END SUBROUTINE Nvalues_2DArrayI
62
63	INTEGER FUNCTION index_list_coordsI(Ncoords, coords, icoord)
64	! Function to provide the index of a given coordinate within a list of integer coordinates
65
66	IMPLICIT NONE
67
68	INTEGER, INTENT(in) :: Ncoords
69	INTEGER, DIMENSION(Ncoords,2), INTENT(in) :: coords
70	INTEGER, DIMENSION(2), INTENT(in) :: icoord
71
72	! Local
73	INTEGER, DIMENSION(Ncoords) :: dist
74	INTEGER :: i,mindist
75	INTEGER, DIMENSION(1) :: iloc
76
77	!!!!!!! Variables
78	! Ncoords: number of coordinates in the list
79	! coords: list of coordinates
80	! icoord: coordinate to find
81
82	fname = 'index_list_coordsI'
83
84	dist = (coords(:,1)-icoord(1))2+(coords(:,2)-icoord(2))2
85
86	IF (ANY(dist == 0)) THEN
87	iloc = MINLOC(dist)
88	index_list_coordsI = iloc(1)
89	ELSE
90	index_list_coordsI = -1
91	END IF
92
93	END FUNCTION index_list_coordsI
94
95	INTEGER FUNCTION Index1DArrayI(array1D, d1, val)
96	! Function to provide the first index of a given value inside a 1D integer array
97
98	IMPLICIT NONE
99
100	INTEGER, INTENT(in) :: d1
101	INTEGER, INTENT(in) :: val
102	INTEGER, DIMENSION(d1), INTENT(in) :: array1D
103
104	! Local
105	INTEGER :: i
106
107	fname = 'Index1DArrayI'
108
109	Index1DArrayI = -1
110
111	DO i=1,d1
112	IF (array1d(i) == val) THEN
113	Index1DArrayI = i
114	EXIT
115	END IF
116	END DO
117
118	END FUNCTION Index1DArrayI
119
120	INTEGER FUNCTION Index1DArrayR(array1D, d1, val)
121	! Function to provide the first index of a given value inside a 1D real array
122
123	IMPLICIT NONE
124
125	INTEGER, INTENT(in) :: d1
126	REAL, INTENT(in) :: val
127	REAL, DIMENSION(d1), INTENT(in) :: array1D
128
129	! Local
130	INTEGER :: i
131
132	fname = 'Index1DArrayR'
133
134	Index1DArrayR = -1
135
136	DO i=1,d1
137	IF (array1d(i) == val) THEN
138	Index1DArrayR = i
139	EXIT
140	END IF
141	END DO
142
143	END FUNCTION Index1DArrayR
144
145	INTEGER FUNCTION Index1DArrayR_K(array1D, d1, val)
146	! Function to provide the first index of a given value inside a 1D real(r_k) array
147
148	IMPLICIT NONE
149
150	INTEGER, INTENT(in) :: d1
151	REAL(r_k), INTENT(in) :: val
152	REAL(r_k), DIMENSION(d1), INTENT(in) :: array1D
153
154	! Local
155	INTEGER :: i
156
157	fname = 'Index1DArrayR_K'
158
159	Index1DArrayR_K = -1
160
161	DO i=1,d1
162	IF (array1d(i) == val) THEN
163	Index1DArrayR_K = i
164	EXIT
165	END IF
166	END DO
167
168	END FUNCTION Index1DArrayR_K
169
170	FUNCTION Index2DArrayR(array2D, d1, d2, val)
171	! Function to provide the first index of a given value inside a 2D real array
172
173	IMPLICIT NONE
174
175	INTEGER, INTENT(in) :: d1, d2
176	REAL, INTENT(in) :: val
177	REAL, DIMENSION(d1,d2), INTENT(in) :: array2D
178	INTEGER, DIMENSION(2) :: Index2DArrayR
179
180	! Local
181	INTEGER :: i, j
182
183	fname = 'Index2DArrayR'
184
185	Index2DArrayR = -1
186
187	DO i=1,d1
188	DO j=1,d2
189	IF (array2d(i,j) == val) THEN
190	Index2DArrayR(1) = i
191	Index2DArrayR(2) = j
192	EXIT
193	END IF
194	END DO
195	END DO
196
197	END FUNCTION Index2DArrayR
198
199	FUNCTION Index2DArrayR_K(array2D, d1, d2, val)
200	! Function to provide the first index of a given value inside a 2D real array
201
202	IMPLICIT NONE
203
204	INTEGER, INTENT(in) :: d1, d2
205	REAL(r_k), INTENT(in) :: val
206	REAL(r_k), DIMENSION(d1,d2), INTENT(in) :: array2D
207	INTEGER, DIMENSION(2) :: Index2DArrayR_K
208
209	! Local
210	INTEGER :: i, j
211
212	fname = 'Index2DArrayR_K'
213
214	Index2DArrayR_K = -1
215
216	DO i=1,d1
217	DO j=1,d2
218	IF (array2d(i,j) == val) THEN
219	Index2DArrayR_K(1) = i
220	Index2DArrayR_K(2) = j
221	EXIT
222	END IF
223	END DO
224	END DO
225
226	END FUNCTION Index2DArrayR_K
227
228	FUNCTION RangeI(d1, iniv, endv)
229	! Function to provide a range of d1 values from 'iniv' to 'endv', of integer values in a vector
230
231	IMPLICIT NONE
232
233	INTEGER, INTENT(in) :: d1, iniv, endv
234	INTEGER, DIMENSION(d1) :: RangeI
235
236	! Local
237	INTEGER :: i, intv
238
239	fname = 'RangeI'
240
241	intv = (endv - iniv) / (d1*1 - 1)
242
243	RangeI(1) = iniv
244	DO i=2,d1
245	RangeI(i) = RangeI(i-1) + intv
246	END DO
247
248	END FUNCTION RangeI
249
250	FUNCTION RangeR(d1, iniv, endv)
251	! Function to provide a range of d1 from 'iniv' to 'endv', of real values in a vector
252
253	IMPLICIT NONE
254
255	INTEGER, INTENT(in) :: d1
256	REAL, INTENT(in) :: iniv, endv
257	REAL, DIMENSION(d1) :: RangeR
258
259	! Local
260	INTEGER :: i
261	REAL :: intv
262
263	fname = 'RangeR'
264
265	intv = (endv - iniv) / (d1*1. - 1.)
266
267	RangeR(1) = iniv
268	DO i=2,d1
269	RangeR(i) = RangeR(i-1) + intv
270	END DO
271
272	END FUNCTION RangeR
273
274	FUNCTION RangeR_K(d1, iniv, endv)
275	! Function to provide a range of d1 from 'iniv' to 'endv', of real(r_k) values in a vector
276
277	IMPLICIT NONE
278
279	INTEGER, INTENT(in) :: d1
280	REAL(r_k), INTENT(in) :: iniv, endv
281	REAL(r_k), DIMENSION(d1) :: RangeR_K
282
283	! Local
284	INTEGER :: i
285	REAL(r_k) :: intv
286
287	fname = 'RangeR_K'
288
289	intv = (endv - iniv) / (d1*oneRK-oneRK)
290
291	RangeR_K(1) = iniv
292	DO i=2,d1
293	RangeR_K(i) = RangeR_K(i-1) + intv
294	END DO
295
296	END FUNCTION RangeR_K
297
298	INTEGER FUNCTION freeunit()
299	! provides the number of a free unit in which open a file
300
301	IMPLICIT NONE
302
303	LOGICAL :: is_used
304
305	is_used = .true.
306	DO freeunit=10,100
307	INQUIRE(unit=freeunit, opened=is_used)
308	IF (.not. is_used) EXIT
309	END DO
310
311	RETURN
312
313	END FUNCTION freeunit
314
315	SUBROUTINE GetInNamelist(namelistfile, param, kindparam, Ival, Rval, Lval, Sval)
316	! Subroutine to get a paramter from a namelistfile
317
318	IMPLICIT NONE
319
320	CHARACTER(LEN=*), INTENT(IN) :: namelistfile, param
321	CHARACTER(LEN=1), INTENT(IN) :: kindparam
322	INTEGER, OPTIONAL, INTENT(OUT) :: Ival
323	REAL, OPTIONAL, INTENT(OUT) :: Rval
324	LOGICAL, OPTIONAL, INTENT(OUT) :: Lval
325	CHARACTER(LEN=200), OPTIONAL, INTENT(OUT) :: Sval
326
327	! Local
328	INTEGER :: i, funit, ios
329	INTEGER :: Lparam, posparam
330	LOGICAL :: is_used
331	CHARACTER(LEN=1000) :: line, message
332	CHARACTER(LEN=200), DIMENSION(2) :: lvals
333	CHARACTER(LEN=200) :: pval
334
335	!!!!!!! Variables
336	! namelistfile: name of the namelist file
337	! param: parameter to get
338	! paramkind: kind of the parameter (I: Integer, L: boolean, R: Real, S: String)
339
340	fname = 'GetInNamelist'
341
342	! Reading dimensions file and defining dimensions
343	is_used = .true.
344	DO funit=10,100
345	INQUIRE(unit=funit, opened=is_used)
346	IF (.not. is_used) EXIT
347	END DO
348
349	OPEN(funit, FILE=TRIM(namelistfile), STATUS='old', FORM='formatted', IOSTAT=ios)
350	IF ( ios /= 0 ) CALL stoprun(message, fname)
351
352	Lparam = LEN_TRIM(param)
353
354	DO i=1,10000
355	READ(funit,"(A200)",END=100)line
356	posparam = INDEX(TRIM(line), TRIM(param))
357	IF (posparam /= 0) EXIT
358
359	END DO
360	100 CONTINUE
361
362	IF (posparam == 0) THEN
363	message = "namelist '" // TRIM(namelistfile) // "' does not have parameter '" // TRIM(param) // &
364	"' !!"
365	CALL stoprun(message, fname)
366	END IF
367
368	CLOSE(UNIT=funit)
369
370	CALL split(line, '=', 2, lvals)
371	IF (kindparam /= 'S') THEN
372	CALL RemoveNonNum(lvals(2), pval)
373	END IF
374
375	! L. Fita, LMD. October 2015
376	! Up to now, only getting scalar values
377	kparam: SELECT CASE (kindparam)
378	CASE ('I')
379	Ival = StoI(pval)
380	! PRINT *,TRIM(param),'= ', Ival
381	CASE ('L')
382	Lval = StoL(pval)
383	! PRINT *,TRIM(param),'= ', Lval
384	CASE ('R')
385	Rval = StoR(pval)
386	! PRINT *,TRIM(param),'= ', Rval
387	CASE ('S')
388	Sval = lvals(2)
389
390	CASE DEFAULT
391	message = "type of parameter '" // kindparam // "' not ready !!"
392	CALL stoprun(message, fname)
393
394	END SELECT kparam
395
396	END SUBROUTINE GetInNamelist
397
398	SUBROUTINE stoprun(msg, fname)
399	! Subroutine to stop running and print a message
400
401	IMPLICIT NONE
402
403	CHARACTER(LEN=*), INTENT(IN) :: fname
404	CHARACTER(LEN=*), INTENT(IN) :: msg
405
406	! local
407	CHARACTER(LEN=50) :: errmsg, warnmsg
408
409	errmsg = 'ERROR -- error -- ERROR -- error'
410
411	PRINT *, TRIM(errmsg)
412	PRINT *, ' ' // TRIM(fname) // ': ' // TRIM(msg)
413	STOP -1
414
415	END SUBROUTINE stoprun
416
417	END MODULE module_generic

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

Download in other formats:

Original Format