source: lmdz_wrf/trunk/tools/module_generic.f90 @ 2264

Last change on this file since 2264 was 2235, checked in by lfita, 6 years ago

Working version of `temporal_stats' with 'percentiles'
File size: 12.4 KB
RevLine 
[715]1MODULE module_generic
2! Module with generic functions
[1608]3
4!!!!!!! Subroutines/Functions
[1655]5! freeunit: provides the number of a free unit in which open a file
6! GetInNamelist: Subroutine to get a paramter from a namelistfile
[1612]7! index_list_coordsI: Function to provide the index of a given coordinate within a list of integer coordinates
[1615]8! Index1DArrayI: Function to provide the first index of a given value inside a 1D integer array
[1313]9! Index1DArrayR: Function to provide the first index of a given value inside a 1D real array
[1608]10! Index1DArrayR_K: Function to provide the first index of a given value inside a 1D real(r_k) array
[1313]11! Index2DArrayR: Function to provide the first index of a given value inside a 2D real array
[1653]12! Index2DArrayR_K: Function to provide the first index of a given value inside a 2D real(r_k) array
[1660]13! Nvalues_2DArrayI: Number of different values of a 2D integer array
[1619]14! mat2DPosition: Function to provide the i, j indices of a given value inside a 2D matrix
[2235]15! numberTimes: Function to provide the number of times that a given set of characters happen within a string
[1608]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
[1655]19! stoprun: Subroutine to stop running and print a message
[715]20
[1608]21  USE module_definitions
[1655]22  USE module_basic
[1184]23
[715]24  CONTAINS
25
[1660]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
[1612]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
[1615]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
[764]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
[1653]127    REAL, INTENT(in)                                     :: val
128    REAL, DIMENSION(d1), INTENT(in)                      :: array1D
[764]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
[1608]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
[715]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
[1653]177    REAL, INTENT(in)                                     :: val
178    REAL, DIMENSION(d1,d2), INTENT(in)                   :: array2D
[715]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
[1653]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
[2235]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
[1608]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
[1655]321  INTEGER FUNCTION freeunit()
322! provides the number of a free unit in which open a file
[1608]323
[1619]324    IMPLICIT NONE
325
[1655]326    LOGICAL                                              :: is_used
[1619]327
[1655]328    is_used = .true.
329    DO freeunit=10,100
[1660]330      INQUIRE(unit=freeunit, opened=is_used)
[1655]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)
[1683]436    STOP
[1655]437
438  END SUBROUTINE stoprun
439
[715]440END MODULE module_generic
Note: See TracBrowser for help on using the repository browser.