Context Navigation

module_generic.f90 @ 2329

Last change on this file since 2329 was 2328, checked in by lfita, 6 years ago

Moving:

`zones_homogenization' from 'module_scientific' to 'module_geeric'

File size: 15.5 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	! zones_homogenization: Subroutine to homogenize 2D contiguous zones, zones might be contiguous, but
21	! with different number assigned !
22
23	USE module_definitions
24	USE module_basic
25
26	CONTAINS
27
28	SUBROUTINE Nvalues_2DArrayI(dx, dy, dxy, mat2DI, Nvals, vals)
29	! Subroutine to give the number of different values of a 2D integer array
30
31	IMPLICIT NONE
32
33	INTEGER, INTENT(in) :: dx, dy, dxy
34	INTEGER, DIMENSION(dx,dy), INTENT(in) :: mat2DI
35	INTEGER, INTENT(out) :: Nvals
36	INTEGER, DIMENSION(dxy), INTENT(out) :: vals
37
38	! Local
39	INTEGER :: i, j, ij
40
41	!!!!!!! Variables
42	! dx, dy: size of the 2D space
43	! mat2DI: 2D integer matrix
44	! Nvals: number of different values
45	! vals: vector with the different values
46
47	fname = 'Nvalues_2DArrayI'
48
49	vals = 0
50
51	Nvals = 1
52	vals(1) = mat2DI(1,1)
53	DO i=1,dx
54	DO j=1,dy
55	IF (Index1DArrayI(vals, Nvals, mat2DI(i,j)) == -1) THEN
56	Nvals = Nvals + 1
57	vals(Nvals) = mat2DI(i,j)
58	END IF
59	END DO
60	END DO
61
62	RETURN
63
64	END SUBROUTINE Nvalues_2DArrayI
65
66	INTEGER FUNCTION index_list_coordsI(Ncoords, coords, icoord)
67	! Function to provide the index of a given coordinate within a list of integer coordinates
68
69	IMPLICIT NONE
70
71	INTEGER, INTENT(in) :: Ncoords
72	INTEGER, DIMENSION(Ncoords,2), INTENT(in) :: coords
73	INTEGER, DIMENSION(2), INTENT(in) :: icoord
74
75	! Local
76	INTEGER, DIMENSION(Ncoords) :: dist
77	INTEGER :: i,mindist
78	INTEGER, DIMENSION(1) :: iloc
79
80	!!!!!!! Variables
81	! Ncoords: number of coordinates in the list
82	! coords: list of coordinates
83	! icoord: coordinate to find
84
85	fname = 'index_list_coordsI'
86
87	dist = (coords(:,1)-icoord(1))2+(coords(:,2)-icoord(2))2
88
89	IF (ANY(dist == 0)) THEN
90	iloc = MINLOC(dist)
91	index_list_coordsI = iloc(1)
92	ELSE
93	index_list_coordsI = -1
94	END IF
95
96	END FUNCTION index_list_coordsI
97
98	INTEGER FUNCTION Index1DArrayI(array1D, d1, val)
99	! Function to provide the first index of a given value inside a 1D integer array
100
101	IMPLICIT NONE
102
103	INTEGER, INTENT(in) :: d1
104	INTEGER, INTENT(in) :: val
105	INTEGER, DIMENSION(d1), INTENT(in) :: array1D
106
107	! Local
108	INTEGER :: i
109
110	fname = 'Index1DArrayI'
111
112	Index1DArrayI = -1
113
114	DO i=1,d1
115	IF (array1d(i) == val) THEN
116	Index1DArrayI = i
117	EXIT
118	END IF
119	END DO
120
121	END FUNCTION Index1DArrayI
122
123	INTEGER FUNCTION Index1DArrayR(array1D, d1, val)
124	! Function to provide the first index of a given value inside a 1D real array
125
126	IMPLICIT NONE
127
128	INTEGER, INTENT(in) :: d1
129	REAL, INTENT(in) :: val
130	REAL, DIMENSION(d1), INTENT(in) :: array1D
131
132	! Local
133	INTEGER :: i
134
135	fname = 'Index1DArrayR'
136
137	Index1DArrayR = -1
138
139	DO i=1,d1
140	IF (array1d(i) == val) THEN
141	Index1DArrayR = i
142	EXIT
143	END IF
144	END DO
145
146	END FUNCTION Index1DArrayR
147
148	INTEGER FUNCTION Index1DArrayR_K(array1D, d1, val)
149	! Function to provide the first index of a given value inside a 1D real(r_k) array
150
151	IMPLICIT NONE
152
153	INTEGER, INTENT(in) :: d1
154	REAL(r_k), INTENT(in) :: val
155	REAL(r_k), DIMENSION(d1), INTENT(in) :: array1D
156
157	! Local
158	INTEGER :: i
159
160	fname = 'Index1DArrayR_K'
161
162	Index1DArrayR_K = -1
163
164	DO i=1,d1
165	IF (array1d(i) == val) THEN
166	Index1DArrayR_K = i
167	EXIT
168	END IF
169	END DO
170
171	END FUNCTION Index1DArrayR_K
172
173	FUNCTION Index2DArrayR(array2D, d1, d2, val)
174	! Function to provide the first index of a given value inside a 2D real array
175
176	IMPLICIT NONE
177
178	INTEGER, INTENT(in) :: d1, d2
179	REAL, INTENT(in) :: val
180	REAL, DIMENSION(d1,d2), INTENT(in) :: array2D
181	INTEGER, DIMENSION(2) :: Index2DArrayR
182
183	! Local
184	INTEGER :: i, j
185
186	fname = 'Index2DArrayR'
187
188	Index2DArrayR = -1
189
190	DO i=1,d1
191	DO j=1,d2
192	IF (array2d(i,j) == val) THEN
193	Index2DArrayR(1) = i
194	Index2DArrayR(2) = j
195	EXIT
196	END IF
197	END DO
198	END DO
199
200	END FUNCTION Index2DArrayR
201
202	FUNCTION Index2DArrayR_K(array2D, d1, d2, val)
203	! Function to provide the first index of a given value inside a 2D real array
204
205	IMPLICIT NONE
206
207	INTEGER, INTENT(in) :: d1, d2
208	REAL(r_k), INTENT(in) :: val
209	REAL(r_k), DIMENSION(d1,d2), INTENT(in) :: array2D
210	INTEGER, DIMENSION(2) :: Index2DArrayR_K
211
212	! Local
213	INTEGER :: i, j
214
215	fname = 'Index2DArrayR_K'
216
217	Index2DArrayR_K = -1
218
219	DO i=1,d1
220	DO j=1,d2
221	IF (array2d(i,j) == val) THEN
222	Index2DArrayR_K(1) = i
223	Index2DArrayR_K(2) = j
224	EXIT
225	END IF
226	END DO
227	END DO
228
229	END FUNCTION Index2DArrayR_K
230
231	INTEGER FUNCTION numberTimes(String, charv)
232	! Function to provide the number of times that a given set of characters happen within a string
233
234	IMPLICIT NONE
235
236	CHARACTER(LEN=*), INTENT(IN) :: String, charv
237
238	! Local
239	INTEGER :: i, Lstring, Lcharv
240
241	numberTimes = 0
242
243	Lstring = LEN_TRIM(String)
244	Lcharv = LEN_TRIM(charv)
245
246	DO i=1,Lstring - Lcharv
247	IF (String(i:i+Lcharv-1) == TRIM(charv)) numberTimes = numberTimes + 1
248	END DO
249
250	END FUNCTION numberTimes
251
252
253	FUNCTION RangeI(d1, iniv, endv)
254	! Function to provide a range of d1 values from 'iniv' to 'endv', of integer values in a vector
255
256	IMPLICIT NONE
257
258	INTEGER, INTENT(in) :: d1, iniv, endv
259	INTEGER, DIMENSION(d1) :: RangeI
260
261	! Local
262	INTEGER :: i, intv
263
264	fname = 'RangeI'
265
266	intv = (endv - iniv) / (d1*1 - 1)
267
268	RangeI(1) = iniv
269	DO i=2,d1
270	RangeI(i) = RangeI(i-1) + intv
271	END DO
272
273	END FUNCTION RangeI
274
275	FUNCTION RangeR(d1, iniv, endv)
276	! Function to provide a range of d1 from 'iniv' to 'endv', of real values in a vector
277
278	IMPLICIT NONE
279
280	INTEGER, INTENT(in) :: d1
281	REAL, INTENT(in) :: iniv, endv
282	REAL, DIMENSION(d1) :: RangeR
283
284	! Local
285	INTEGER :: i
286	REAL :: intv
287
288	fname = 'RangeR'
289
290	intv = (endv - iniv) / (d1*1. - 1.)
291
292	RangeR(1) = iniv
293	DO i=2,d1
294	RangeR(i) = RangeR(i-1) + intv
295	END DO
296
297	END FUNCTION RangeR
298
299	FUNCTION RangeR_K(d1, iniv, endv)
300	! Function to provide a range of d1 from 'iniv' to 'endv', of real(r_k) values in a vector
301
302	IMPLICIT NONE
303
304	INTEGER, INTENT(in) :: d1
305	REAL(r_k), INTENT(in) :: iniv, endv
306	REAL(r_k), DIMENSION(d1) :: RangeR_K
307
308	! Local
309	INTEGER :: i
310	REAL(r_k) :: intv
311
312	fname = 'RangeR_K'
313
314	intv = (endv - iniv) / (d1*oneRK-oneRK)
315
316	RangeR_K(1) = iniv
317	DO i=2,d1
318	RangeR_K(i) = RangeR_K(i-1) + intv
319	END DO
320
321	END FUNCTION RangeR_K
322
323	INTEGER FUNCTION freeunit()
324	! provides the number of a free unit in which open a file
325
326	IMPLICIT NONE
327
328	LOGICAL :: is_used
329
330	is_used = .true.
331	DO freeunit=10,100
332	INQUIRE(unit=freeunit, opened=is_used)
333	IF (.not. is_used) EXIT
334	END DO
335
336	RETURN
337
338	END FUNCTION freeunit
339
340	SUBROUTINE GetInNamelist(namelistfile, param, kindparam, Ival, Rval, Lval, Sval)
341	! Subroutine to get a paramter from a namelistfile
342
343	IMPLICIT NONE
344
345	CHARACTER(LEN=*), INTENT(IN) :: namelistfile, param
346	CHARACTER(LEN=1), INTENT(IN) :: kindparam
347	INTEGER, OPTIONAL, INTENT(OUT) :: Ival
348	REAL, OPTIONAL, INTENT(OUT) :: Rval
349	LOGICAL, OPTIONAL, INTENT(OUT) :: Lval
350	CHARACTER(LEN=200), OPTIONAL, INTENT(OUT) :: Sval
351
352	! Local
353	INTEGER :: i, funit, ios
354	INTEGER :: Lparam, posparam
355	LOGICAL :: is_used
356	CHARACTER(LEN=1000) :: line, message
357	CHARACTER(LEN=200), DIMENSION(2) :: lvals
358	CHARACTER(LEN=200) :: pval
359
360	!!!!!!! Variables
361	! namelistfile: name of the namelist file
362	! param: parameter to get
363	! paramkind: kind of the parameter (I: Integer, L: boolean, R: Real, S: String)
364
365	fname = 'GetInNamelist'
366
367	! Reading dimensions file and defining dimensions
368	is_used = .true.
369	DO funit=10,100
370	INQUIRE(unit=funit, opened=is_used)
371	IF (.not. is_used) EXIT
372	END DO
373
374	OPEN(funit, FILE=TRIM(namelistfile), STATUS='old', FORM='formatted', IOSTAT=ios)
375	IF ( ios /= 0 ) CALL stoprun(message, fname)
376
377	Lparam = LEN_TRIM(param)
378
379	DO i=1,10000
380	READ(funit,"(A200)",END=100)line
381	posparam = INDEX(TRIM(line), TRIM(param))
382	IF (posparam /= 0) EXIT
383
384	END DO
385	100 CONTINUE
386
387	IF (posparam == 0) THEN
388	message = "namelist '" // TRIM(namelistfile) // "' does not have parameter '" // TRIM(param) // &
389	"' !!"
390	CALL stoprun(message, fname)
391	END IF
392
393	CLOSE(UNIT=funit)
394
395	CALL split(line, '=', 2, lvals)
396	IF (kindparam /= 'S') THEN
397	CALL RemoveNonNum(lvals(2), pval)
398	END IF
399
400	! L. Fita, LMD. October 2015
401	! Up to now, only getting scalar values
402	kparam: SELECT CASE (kindparam)
403	CASE ('I')
404	Ival = StoI(pval)
405	! PRINT *,TRIM(param),'= ', Ival
406	CASE ('L')
407	Lval = StoL(pval)
408	! PRINT *,TRIM(param),'= ', Lval
409	CASE ('R')
410	Rval = StoR(pval)
411	! PRINT *,TRIM(param),'= ', Rval
412	CASE ('S')
413	Sval = lvals(2)
414
415	CASE DEFAULT
416	message = "type of parameter '" // kindparam // "' not ready !!"
417	CALL stoprun(message, fname)
418
419	END SELECT kparam
420
421	END SUBROUTINE GetInNamelist
422
423	SUBROUTINE stoprun(msg, fname)
424	! Subroutine to stop running and print a message
425
426	IMPLICIT NONE
427
428	CHARACTER(LEN=*), INTENT(IN) :: fname
429	CHARACTER(LEN=*), INTENT(IN) :: msg
430
431	! local
432	CHARACTER(LEN=50) :: errmsg, warnmsg
433
434	errmsg = 'ERROR -- error -- ERROR -- error'
435
436	PRINT *, TRIM(errmsg)
437	PRINT *, ' ' // TRIM(fname) // ': ' // TRIM(msg)
438	STOP
439
440	END SUBROUTINE stoprun
441
442	SUBROUTINE zones_homogenization(dx, dy, inzones, outzones)
443	! Subroutine to homogenize 2D contiguous zones, zones might be contiguous, but with different number assigned !
444	! Here we have a 2D matrix of integers, with contiguous integer filled zones, zero outside any zone
445	! It might be, that within the same zone, might be lines which do not share the same integer
446	! 0 0 0 0 0 0 0 0 0 0
447	! 0 1 1 0 0 0 1 1 0 0
448	! 0 2 0 0 1 == > 0 1 0 0 2
449	! 0 1 1 0 0 0 1 1 0 0
450
451	IMPLICIT NONE
452
453	INTEGER, INTENT(in) :: dx, dy
454	INTEGER, DIMENSION(dx,dy), INTENT(in) :: inzones
455	INTEGER, DIMENSION(dx,dy), INTENT(out) :: outzones
456
457	! Local
458	INTEGER :: i,j,k
459	INTEGER :: Nmaxzones, TOTzones
460	LOGICAL :: assigned
461	INTEGER, DIMENSION(dy) :: prevline
462	INTEGER, DIMENSION(dx) :: Nyzones
463	INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: zones
464
465	!!!!!!! Variables
466	! dx, dy: Shape of the 2D space
467	! inzones: zones to homogenize
468	! outzones: zones homogenized
469
470	fname = 'zones_homogenization'
471
472	! Maximum possible number of zones
473	Nmaxzones = INT((dx/2)*(dy/2))
474
475	! Matrix with [i,j,Nzone,izone/ezone]
476	IF (ALLOCATED(zones)) DEALLOCATE(zones)
477	ALLOCATE(zones(dx,Nmaxzones,3))
478
479	zones = 0
480	Nyzones = 0
481	! Getting beginning/end of y-bands
482	DO i=1, dx
483	k = 0
484	j = 1
485	IF (inzones(i,j) /= 0) THEN
486	k = k + 1
487	zones(i,k,1) = j
488	zones(i,k,3) = k
489	END IF
490	DO j=2, dy
491	IF ( (inzones(i,j) /= 0) .AND. (inzones(i,j-1) == 0)) THEN
492	k = k+1
493	zones(i,k,1) = j
494	zones(i,k,3) = k
495	ELSE IF ( (inzones(i,j-1) /= 0) .AND. (inzones(i,j) == 0)) THEN
496	zones(i,k,2) = j-1
497	zones(i,k,3) = k
498	END IF
499	END DO
500	IF (k > 0) THEN
501	IF (zones(i,k,2) == 0) zones(i,k,2) = dy
502	END IF
503	Nyzones(i) = k
504	END DO
505
506	! Homogenizing contigous zones
507	outzones = 0
508	TOTzones = 0
509	i = 1
510	DO k = 1, Nyzones(i)
511	TOTzones = TOTzones + 1
512	DO j=zones(i,k,1), zones(i,k,2)
513	outzones(i,j) = TOTzones
514	END DO
515	END DO
516
517	DO i=2, dx
518	prevline = outzones(i-1,:)
519	DO k = 1, Nyzones(i)
520	assigned = .FALSE.
521	DO j=zones(i,k,1), zones(i,k,2)
522	IF (prevline(j) /= 0) THEN
523	outzones(i,zones(i,k,1):zones(i,k,2)) = prevline(j)
524	assigned = .TRUE.
525	EXIT
526	END IF
527	END DO
528	IF (.NOT.assigned) THEN
529	TOTzones = TOTzones + 1
530	DO j=zones(i,k,1), zones(i,k,2)
531	outzones(i,j) = TOTzones
532	END DO
533	END IF
534	END DO
535	END DO
536
537	IF (ALLOCATED(zones)) DEALLOCATE(zones)
538
539	END SUBROUTINE zones_homogenization
540
541	END MODULE module_generic

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

Download in other formats:

Original Format