source: lmdz_wrf/trunk/tools/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
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
[1608]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
[1655]18! stoprun: Subroutine to stop running and print a message
[715]19
[1608]20  USE module_definitions
[1655]21  USE module_basic
[1184]22
[715]23  CONTAINS
24
[1660]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
[1612]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
[1615]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
[764]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
[1653]126    REAL, INTENT(in)                                     :: val
127    REAL, DIMENSION(d1), INTENT(in)                      :: array1D
[764]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
[1608]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
[715]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
[1653]176    REAL, INTENT(in)                                     :: val
177    REAL, DIMENSION(d1,d2), INTENT(in)                   :: array2D
[715]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
[1653]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
[1608]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
[1655]298  INTEGER FUNCTION freeunit()
299! provides the number of a free unit in which open a file
[1608]300
[1619]301    IMPLICIT NONE
302
[1655]303    LOGICAL                                              :: is_used
[1619]304
[1655]305    is_used = .true.
306    DO freeunit=10,100
[1660]307      INQUIRE(unit=freeunit, opened=is_used)
[1655]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
[715]417END MODULE module_generic
Note: See TracBrowser for help on using the repository browser.