Context Navigation

module_generic.f90 @ 2248

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

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

Download in other formats:

Original Format