New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
function.f90 in branches/UKMO/nemo_v3_6_STABLE_copy/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/UKMO/nemo_v3_6_STABLE_copy/NEMOGCM/TOOLS/SIREN/src/function.f90 @ 5783

Last change on this file since 5783 was 5783, checked in by davestorkey, 8 years ago

UKMO/nemo_v3_6_STABLE_copy branch : commit changes from nemo_v3_6_STABLE
branch up to latest revision.

File size: 33.3 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! MODULE: fct
6!
7! DESCRIPTION:
8!> @brief
9!> This module groups some basic useful function.
10!>
11!> @details
12!>  to get free I/O unit number:<br/>
13!> @code
14!>  il_id=fct_getunit()
15!> @endcode
16!>
17!>  to convert "numeric" to string character:<br/>
18!> @code
19!>  cl_string=fct_str(numeric)
20!> @endcode
21!>  - "numeric" could be integer, real, or logical
22!>
23!>  to concatenate "numeric" to a string character:<br/>
24!> @code
25!>  cl_str=cd_char//num
26!> @endcode
27!>  - cd_char is the string character
28!>  - num is the numeric value (integer, real or logical) 
29!>
30!>  to concatenate all the element of a character array:<br/>
31!> @code
32!>  cl_string=fct_concat(cd_arr [,cd_sep])
33!> @endcode
34!>  - cd_arr is a 1D array of character
35!>  - cd_sep is a separator character to add between each element of cd_arr
36!> [optional]
37!>
38!>  to convert character from lower to upper case:<br/>
39!> @code
40!>  cl_upper=fct_upper(cd_var)
41!> @endcode
42!>
43!>  to convert character from upper to lower case:<br/>
44!> @code
45!>  cl_lower=fct_lower(cd_var)
46!> @endcode
47!>
48!>  to check if character is numeric
49!> @code
50!>  ll_is_num=fct_is_num(cd_var)
51!> @endcode
52!>
53!>  to check if character is real
54!> @code
55!>  ll_is_real=fct_is_real(cd_var)
56!> @endcode
57!>
58!>  to split string into substring and return one of the element:<br/> 
59!> @code
60!>  cl_str=fct_split(cd_string ,id_ind [,cd_sep])
61!> @endcode
62!>  - cd_string is a string of character
63!>  - id_ind is the indice of the lement to extract
64!>  - cd_sep is the separator use to split cd_string (default '|')
65!>
66!>  to get basename (name without path):<br/>
67!> @code
68!>  cl_str=fct_basename(cd_string [,cd_sep])
69!> @endcode
70!>  - cd_string is the string filename
71!>  - cd_sep is the separator ti be used (default '/')
72!>
73!>  to get dirname (path of the filename):<br/>
74!> @code
75!>  cl_str=fct_dirname(cd_string [,cd_sep])
76!> @endcode
77!>  - cd_string is the string filename
78!>  - cd_sep is the separator ti be used (default '/')
79!> 
80!> to create a pause statement:<br/>
81!> @code
82!> CALL fct_pause(cd_msg)
83!> @endcode
84!>    - cd_msg : message to be added [optional]
85!>
86!> to handle frotran error:<br/>
87!> @code
88!> CALL fct_err(id_status)
89!> @endcode
90!>
91!>
92!> @author
93!> J.Paul
94! REVISION HISTORY:
95!> @date November, 2013 - Initial Version
96!> @date September, 2014
97!> - add header
98!
99!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
100!----------------------------------------------------------------------
101MODULE fct
102   USE kind                            ! F90 kind parameter
103   IMPLICIT NONE
104   ! NOTE_avoid_public_variables_if_possible
105
106   ! function and subroutine
107   PUBLIC :: fct_getunit  !< returns free unit number
108   PUBLIC :: fct_str      !< convert numeric to string character
109   PUBLIC :: OPERATOR(//) !< concatenate operator
110   PUBLIC :: fct_concat   !< concatenate all the element of a character array
111   PUBLIC :: fct_upper    !< convert character from lower to upper case
112   PUBLIC :: fct_lower    !< convert character from upper to lower case
113   PUBLIC :: fct_is_num   !< check if character is numeric
114   PUBLIC :: fct_is_real  !< check if character is real
115   PUBLIC :: fct_split    !< split string into substring
116   PUBLIC :: fct_basename !< return basename (name without path)
117   PUBLIC :: fct_dirname  !< return dirname (path without filename)
118   PUBLIC :: fct_pause    !< pause statement
119   PUBLIC :: fct_err      !< handle fortran error status
120
121   PRIVATE :: fct__i1_str ! convert integer(1) to string character
122   PRIVATE :: fct__i2_str ! convert integer(2) to string character
123   PRIVATE :: fct__i4_str ! convert integer(4) to string character
124   PRIVATE :: fct__i8_str ! convert integer(8) to string character
125   PRIVATE :: fct__r4_str ! convert real(4) to string character
126   PRIVATE :: fct__r8_str ! convert real(8) to string character
127   PRIVATE :: fct__l_str  ! convert logical to string character
128   PRIVATE :: fct__i1_cat ! concatenate integer(1) to string character
129   PRIVATE :: fct__i2_cat ! concatenate integer(2) to string character
130   PRIVATE :: fct__i4_cat ! concatenate integer(4) to string character
131   PRIVATE :: fct__i8_cat ! concatenate integer(8) to string character
132   PRIVATE :: fct__r4_cat ! concatenate real(4) to string character
133   PRIVATE :: fct__r8_cat ! concatenate real(8) to string character
134   PRIVATE :: fct__l_cat  ! concatenate logical to string character
135   PRIVATE :: fct__split_space ! split string into substring using space as separator
136
137   INTERFACE fct_str
138      MODULE PROCEDURE fct__i1_str ! convert integer(1) to string character
139      MODULE PROCEDURE fct__i2_str ! convert integer(2) to string character
140      MODULE PROCEDURE fct__i4_str ! convert integer(4) to string character
141      MODULE PROCEDURE fct__i8_str ! convert integer(8) to string character
142      MODULE PROCEDURE fct__r4_str ! convert real(4) to string character
143      MODULE PROCEDURE fct__r8_str ! convert real(8) to string character
144      MODULE PROCEDURE fct__l_str  ! convert logical to string character
145   END INTERFACE fct_str
146
147   INTERFACE OPERATOR(//)
148      MODULE PROCEDURE fct__i1_cat ! concatenate integer(1) to string character
149      MODULE PROCEDURE fct__i2_cat ! concatenate integer(2) to string character
150      MODULE PROCEDURE fct__i4_cat ! concatenate integer(4) to string character
151      MODULE PROCEDURE fct__i8_cat ! concatenate integer(8) to string character
152      MODULE PROCEDURE fct__r4_cat ! concatenate real(4) to string character
153      MODULE PROCEDURE fct__r8_cat ! concatenate real(8) to string character
154      MODULE PROCEDURE fct__l_cat  ! concatenate logical to string character
155   END INTERFACE
156
157CONTAINS
158   !-------------------------------------------------------------------
159   !> @brief This function concatenate character and integer(1) (as character).
160   !
161   !> @author J.Paul
162   !> @date September, 2014 - Initial Version
163   !
164   !> @param[in] cd_char   string character
165   !> @param[in] bd_val    integer(1) variable value
166   !> @return string character
167   !-------------------------------------------------------------------
168   PURE CHARACTER(LEN=lc) FUNCTION fct__i1_cat(cd_char, bd_val) 
169 
170      ! arguments
171      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
172      INTEGER(i1),       INTENT(IN) :: bd_val
173
174      ! local variable
175      CHARACTER(LEN=lc) :: cl_val
176      !----------------------------------------------------------------
177 
178      cl_val = fct_str(bd_val)
179      fct__i1_cat=TRIM(cd_char)//TRIM(cl_val)
180
181   END FUNCTION fct__i1_cat 
182   !-------------------------------------------------------------------
183   !> @brief This function concatenate character and integer(2) (as character).
184   !
185   !> @author J.Paul
186   !> @date September, 2014 - Initial Version
187   !
188   !> @param[in] cd_char   string character
189   !> @param[in] sd_val    integer(2) variable value
190   !> @return string character
191   !-------------------------------------------------------------------
192   PURE CHARACTER(LEN=lc) FUNCTION fct__i2_cat(cd_char, sd_val) 
193 
194      ! arguments
195      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
196      INTEGER(i2),       INTENT(IN) :: sd_val
197
198      ! local variable
199      CHARACTER(LEN=lc) :: cl_val
200      !----------------------------------------------------------------
201 
202      cl_val = fct_str(sd_val)
203      fct__i2_cat=TRIM(cd_char)//TRIM(cl_val)
204
205   END FUNCTION fct__i2_cat 
206   !-------------------------------------------------------------------
207   !> @brief This function concatenate character and integer(4) (as character).
208   !
209   !> @author J.Paul
210   !> @date November, 2013 - Initial Version
211   !
212   !> @param[in] cd_char   string character
213   !> @param[in] id_val    integer(4) variable value
214   !> @return string character
215   !-------------------------------------------------------------------
216   PURE CHARACTER(LEN=lc) FUNCTION fct__i4_cat(cd_char, id_val) 
217 
218      ! arguments
219      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
220      INTEGER(i4),       INTENT(IN) :: id_val
221
222      ! local variable
223      CHARACTER(LEN=lc) :: cl_val
224      !----------------------------------------------------------------
225 
226      cl_val = fct_str(id_val)
227      fct__i4_cat=TRIM(cd_char)//TRIM(cl_val)
228
229   END FUNCTION fct__i4_cat 
230   !-------------------------------------------------------------------
231   !> @brief This function concatenate character and integer(8) (as character).
232   !
233   !> @author J.Paul
234   !> @date November, 2013 - Initial Version
235   !
236   !> @param[in] cd_char   string character
237   !> @param[in] kd_val    integer(8) variable value
238   !> @return string character
239   !-------------------------------------------------------------------
240   PURE CHARACTER(LEN=lc) FUNCTION fct__i8_cat(cd_char, kd_val) 
241 
242      ! arguments
243      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
244      INTEGER(i8),       INTENT(IN) :: kd_val
245
246      ! local variable
247      CHARACTER(LEN=lc) :: cl_val
248      !----------------------------------------------------------------
249 
250      cl_val = fct_str(kd_val)
251      fct__i8_cat=TRIM(cd_char)//TRIM(cl_val)
252
253   END FUNCTION fct__i8_cat 
254   !-------------------------------------------------------------------
255   !> @brief This function concatenate character and real(4) (as character).
256   !
257   !> @author J.Paul
258   !> @date November, 2013 - Initial Version
259   !
260   !> @param[in] cd_char   string character
261   !> @param[in] rd_val    real(4) variable value
262   !> @return string character
263   !-------------------------------------------------------------------
264   PURE CHARACTER(LEN=lc) FUNCTION fct__r4_cat(cd_char, rd_val) 
265 
266      ! arguments
267      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
268      REAL(sp),          INTENT(IN) :: rd_val
269
270      ! local variable
271      CHARACTER(LEN=lc) :: cl_val
272      !----------------------------------------------------------------
273 
274      cl_val = fct_str(rd_val)
275      fct__r4_cat=TRIM(cd_char)//TRIM(cl_val)
276
277   END FUNCTION fct__r4_cat 
278   !-------------------------------------------------------------------
279   !> @brief This function concatenate character and real(8) (as character).
280   !>
281   !> @author J.Paul
282   !> @date November, 2013 - Initial Version
283   !>
284   !> @param[in] cd_char   string character
285   !> @param[in] dd_val    real(8) variable value
286   !> @return string character
287   !-------------------------------------------------------------------
288   PURE CHARACTER(LEN=lc) FUNCTION fct__r8_cat(cd_char, dd_val) 
289 
290      ! arguments
291      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
292      REAL(dp),          INTENT(IN) :: dd_val
293
294      ! local variable
295      CHARACTER(LEN=lc) :: cl_val
296      !----------------------------------------------------------------
297 
298      cl_val = fct_str(dd_val)
299      fct__r8_cat=TRIM(cd_char)//TRIM(cl_val)
300
301   END FUNCTION fct__r8_cat 
302   !-------------------------------------------------------------------
303   !> @brief This function concatenate character and logical (as character).
304   !>
305   !> @author J.Paul
306   !> @date November, 2013 - Initial Version
307   !>
308   !> @param[in] cd_char   string character
309   !> @param[in] ld_val    logical variable value
310   !> @return string character
311   !-------------------------------------------------------------------
312   PURE CHARACTER(LEN=lc) FUNCTION fct__l_cat(cd_char, ld_val) 
313 
314      ! arguments
315      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
316      LOGICAL,           INTENT(IN) :: ld_val
317
318      ! local variable
319      CHARACTER(LEN=lc) :: cl_val
320      !----------------------------------------------------------------
321 
322      cl_val = fct_str(ld_val)
323      fct__l_cat=TRIM(cd_char)//TRIM(cl_val)
324
325   END FUNCTION fct__l_cat 
326   !-------------------------------------------------------------------
327   !> @brief This function returns the next available I/O unit number.
328   !>
329   !> @author J.Paul
330   !> @date November, 2013 - Initial Version
331   !>
332   !> @return file id
333   !-------------------------------------------------------------------
334   INTEGER(i4) FUNCTION fct_getunit() 
335 
336      ! local variable
337      LOGICAL ::  ll_opened 
338      !----------------------------------------------------------------
339      ! initialise
340      fct_getunit = 10 
341 
342      INQUIRE(UNIT=fct_getunit, OPENED=ll_opened) 
343      DO WHILE( ll_opened ) 
344         fct_getunit = fct_getunit + 1 
345         INQUIRE(UNIT=fct_getunit, OPENED=ll_opened) 
346      ENDDO 
347 
348   END FUNCTION fct_getunit 
349   !-------------------------------------------------------------------
350   !> @brief This subroutine handle Fortran status.
351   !
352   !> @author J.Paul
353   !> @date November, 2013 - Initial Version
354   !>
355   !> @param[in] id_status
356   !-------------------------------------------------------------------
357   SUBROUTINE fct_err(id_status)
358
359      ! Argument
360      INTEGER(i4),       INTENT(IN) :: id_status
361      !----------------------------------------------------------------
362
363      IF( id_status /= 0 )THEN
364         !CALL ERRSNS() ! not F95 standard
365         PRINT *, "FORTRAN ERROR"
366         !STOP
367      ENDIF
368
369   END SUBROUTINE fct_err
370   !-------------------------------------------------------------------
371   !> @brief This subroutine  create a pause statement
372   !
373   !> @author J.Paul
374   !> @date November, 2014 - Initial Version
375   !>
376   !> @param[in] cd_msg optional message to be added
377   !-------------------------------------------------------------------
378   SUBROUTINE fct_pause(cd_msg)
379
380      ! Argument
381      CHARACTER(LEN=*), INTENT(IN), OPTIONAL  :: cd_msg
382      !----------------------------------------------------------------
383
384      IF( PRESENT(cd_msg) )THEN
385         WRITE( *, * ) 'Press Enter to continue '//TRIM(cd_msg)
386      ELSE
387         WRITE( *, * ) 'Press Enter to continue'
388      ENDIF
389      READ( *, * )
390
391   END SUBROUTINE fct_pause
392   !-------------------------------------------------------------------
393   !> @brief This function convert logical to string character.
394   !>
395   !> @author J.Paul
396   !> @date November, 2013 - Initial Version
397   !
398   !> @param[in] ld_var logical variable
399   !> @return character of this integer variable
400   !-------------------------------------------------------------------
401   PURE CHARACTER(LEN=lc) FUNCTION fct__l_str(ld_var)
402      IMPLICIT NONE
403      ! Argument     
404      LOGICAL, INTENT(IN) :: ld_var
405
406      ! local variable
407      CHARACTER(LEN=lc) :: cl_tmp
408      !----------------------------------------------------------------
409
410      write(cl_tmp,*) ld_var
411      fct__l_str=TRIM(ADJUSTL(cl_tmp))
412
413   END FUNCTION fct__l_str
414   !-------------------------------------------------------------------
415   !> @brief This function convert integer(1) to string character.
416   !>
417   !> @author J.Paul
418   !> @date November, 2013 - Initial Version
419   !
420   !> @param[in] bd_var integer(1) variable
421   !> @return character of this integer variable
422   !-------------------------------------------------------------------
423   PURE CHARACTER(LEN=lc) FUNCTION fct__i1_str(bd_var)
424      IMPLICIT NONE
425      ! Argument     
426      INTEGER(i1), INTENT(IN) :: bd_var
427
428      ! local variable
429      CHARACTER(LEN=lc) :: cl_tmp
430      !----------------------------------------------------------------
431
432      write(cl_tmp,*) bd_var
433      fct__i1_str=TRIM(ADJUSTL(cl_tmp))
434
435   END FUNCTION fct__i1_str
436   !-------------------------------------------------------------------
437   !> @brief This function convert integer(2) to string character.
438   !>
439   !> @author J.Paul
440   !> @date November, 2013 - Initial Version
441   !
442   !> @param[in] sd_var integer(2) variable
443   !> @return character of this integer variable
444   !-------------------------------------------------------------------
445   PURE CHARACTER(LEN=lc) FUNCTION fct__i2_str(sd_var)
446      IMPLICIT NONE
447      ! Argument     
448      INTEGER(i2), INTENT(IN) :: sd_var
449
450      ! local variable
451      CHARACTER(LEN=lc) :: cl_tmp
452      !----------------------------------------------------------------
453
454      write(cl_tmp,*) sd_var
455      fct__i2_str=TRIM(ADJUSTL(cl_tmp))
456
457   END FUNCTION fct__i2_str
458   !-------------------------------------------------------------------
459   !> @brief This function convert integer(4) to string character.
460   !>
461   !> @author J.Paul
462   !> @date November, 2013 - Initial Version
463   !
464   !> @param[in] id_var integer(4) variable
465   !> @return character of this integer variable
466   !-------------------------------------------------------------------
467   PURE CHARACTER(LEN=lc) FUNCTION fct__i4_str(id_var)
468      IMPLICIT NONE
469      ! Argument     
470      INTEGER(i4), INTENT(IN) :: id_var
471
472      ! local variable
473      CHARACTER(LEN=lc) :: cl_tmp
474      !----------------------------------------------------------------
475
476      write(cl_tmp,*) id_var
477      fct__i4_str=TRIM(ADJUSTL(cl_tmp))
478
479   END FUNCTION fct__i4_str
480   !-------------------------------------------------------------------
481   !> @brief This function convert integer(8) to string character.
482   !>
483   !> @author J.Paul
484   !> @date November, 2013 - Initial Version
485   !
486   !> @param[in] kd_var integer(8) variable
487   !> @return character of this integer variable
488   !-------------------------------------------------------------------
489   PURE CHARACTER(LEN=lc) FUNCTION fct__i8_str(kd_var)
490      IMPLICIT NONE
491      ! Argument     
492      INTEGER(i8), INTENT(IN) :: kd_var
493
494      ! local variable
495      CHARACTER(LEN=lc) :: cl_tmp
496      !----------------------------------------------------------------
497
498      write(cl_tmp,*) kd_var
499      fct__i8_str=TRIM(ADJUSTL(cl_tmp))
500
501   END FUNCTION fct__i8_str
502   !-------------------------------------------------------------------
503   !> @brief This function convert real(4) to string character.
504   !>
505   !> @author J.Paul
506   !> @date November, 2013 - Initial Version
507   !
508   !> @param[in] rd_var real(4) variable
509   !> @return character of this real variable
510   !-------------------------------------------------------------------
511   PURE CHARACTER(LEN=lc) FUNCTION fct__r4_str(rd_var)
512      IMPLICIT NONE
513      ! Argument     
514      REAL(sp), INTENT(IN) :: rd_var
515
516      ! local variable
517      CHARACTER(LEN=lc) :: cl_tmp
518      !----------------------------------------------------------------
519
520      write(cl_tmp,*) rd_var
521      fct__r4_str=TRIM(ADJUSTL(cl_tmp))
522
523   END FUNCTION fct__r4_str
524   !-------------------------------------------------------------------
525   !> @brief This function convert real(8) to string character.
526   !>
527   !> @author J.Paul
528   !> @date November, 2013 - Initial Version
529   !
530   !> @param[in] dd_var real(8) variable
531   !> @return character of this real variable
532   !-------------------------------------------------------------------
533   PURE CHARACTER(LEN=lc) FUNCTION fct__r8_str(dd_var)
534      IMPLICIT NONE
535      ! Argument     
536      REAL(dp), INTENT(IN) :: dd_var
537
538      ! local variable
539      CHARACTER(LEN=lc) :: cl_tmp
540      !----------------------------------------------------------------
541
542      write(cl_tmp,*) dd_var
543      fct__r8_str=TRIM(ADJUSTL(cl_tmp))
544
545   END FUNCTION fct__r8_str
546   !-------------------------------------------------------------------
547   !> @brief This function concatenate all the element of a character array
548   !> in a character string.
549   !> @details
550   !> optionnally a separator could be added between each element.
551   !>
552   !> @author J.Paul
553   !> @date November, 2013 - Initial Version
554   !
555   !> @param[in] cd_arr array of character
556   !> @param[in] cd_sep separator character
557   !> @return character
558   !-------------------------------------------------------------------
559   PURE CHARACTER(LEN=lc) FUNCTION fct_concat(cd_arr,cd_sep)
560      IMPLICIT NONE
561      ! Argument     
562      CHARACTER(*), DIMENSION(:), INTENT(IN) :: cd_arr
563      CHARACTER(*),               INTENT(IN), OPTIONAL :: cd_sep
564
565      ! local variable
566      CHARACTER(LEN=lc) :: cl_tmp
567      CHARACTER(LEN=lc) :: cl_sep
568      INTEGER(i4)       :: il_size
569
570      ! loop indices
571      INTEGER(i4) :: ji
572      !----------------------------------------------------------------
573
574      cl_sep=''
575      IF(PRESENT(cd_sep)) cl_sep=cd_sep
576
577      il_size=SIZE(cd_arr)
578      fct_concat=''
579      cl_tmp=''
580      DO ji=1,il_size
581
582         WRITE(cl_tmp,*) TRIM(fct_concat)//TRIM(ADJUSTL(cd_arr(ji)))//TRIM(cl_sep)
583         fct_concat=TRIM(ADJUSTL(cl_tmp))
584     
585      ENDDO
586
587   END FUNCTION fct_concat
588   !-------------------------------------------------------------------
589   !> @brief This function convert string character upper case to lower case.
590   !
591   !> @details
592   !> The function IACHAR returns the ASCII value of the character passed
593   !> as argument. The ASCII code has the uppercase alphabet starting at
594   !> code 65, and the lower case one at code 101, therefore
595   !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase
596   !> and the lowercase codes.
597   !
598   !> @author J.Paul
599   !> @date November, 2013 - Initial Version
600   !
601   !> @param[in] cd_var character
602   !> @return lower case character
603   !-------------------------------------------------------------------
604   PURE CHARACTER(LEN=lc) FUNCTION fct_lower(cd_var)
605      IMPLICIT NONE
606      ! Argument     
607      CHARACTER(*), INTENT(IN) :: cd_var
608
609      ! local variable
610      INTEGER(i4)                                  :: il_nletter ! number of letters in variable
611      CHARACTER(LEN=lc)                            :: cl_var
612      CHARACTER(LEN=lc), DIMENSION(:), ALLOCATABLE :: cl_tmp
613
614      INTEGER(i4) :: il_icode    ! ASCII value
615      INTEGER(i4) :: il_lacode   ! ASCII value of the lower case 'a'
616      INTEGER(i4) :: il_uacode   ! ASCII value of the upper case 'A'
617      INTEGER(i4) :: il_uzcode   ! ASCII value of the upper case 'z'
618
619      ! loop indices
620      INTEGER(i4) :: ji
621      !----------------------------------------------------------------
622
623      il_lacode=IACHAR('a')
624      il_uacode=IACHAR('A')
625      il_uzcode=IACHAR('Z')
626
627      cl_var=TRIM(ADJUSTL(cd_var))
628      il_nletter=LEN(TRIM(cl_var))
629      ALLOCATE(cl_tmp(il_nletter))
630      DO ji=1,il_nletter
631         il_icode=IACHAR(cl_var(ji:ji))
632         IF( il_icode >= il_uacode .AND. il_icode <= il_uzcode )THEN
633            ! upper case
634            cl_tmp(ji)=TRIM(CHAR(il_icode + (il_lacode - il_uacode) ))
635         ELSE
636            ! lower case and other character
637            cl_tmp(ji)=TRIM(CHAR(il_icode))
638         ENDIF
639      ENDDO
640
641      fct_lower=TRIM(ADJUSTL(fct_concat(cl_tmp(:))))
642      DEALLOCATE(cl_tmp)
643
644   END FUNCTION fct_lower
645   !-------------------------------------------------------------------
646   !> @brief This function convert string character lower case to upper case.
647   !
648   !> @details
649   !> The function IACHAR returns the ASCII value of the character passed
650   !> as argument. The ASCII code has the uppercase alphabet starting at
651   !> code 65, and the lower case one at code 101, therefore
652   !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase
653   !> and the lowercase codes.
654   !
655   !> @author J.Paul
656   !> @date November, 2013 - Initial Version
657   !
658   !> @param[in] cd_var character
659   !> @return upper case character
660   !-------------------------------------------------------------------
661   PURE CHARACTER(LEN=lc) FUNCTION fct_upper(cd_var)
662      IMPLICIT NONE
663      ! Argument     
664      CHARACTER(*), INTENT(IN) :: cd_var
665
666      ! local variable
667      INTEGER(i4)                                  :: il_nletter ! number of letters in cd_var
668      CHARACTER(LEN=lc)                            :: cl_var
669      CHARACTER(LEN=lc), DIMENSION(:), ALLOCATABLE :: cl_tmp
670
671      INTEGER(i4) :: il_icode    ! ASCII value
672      INTEGER(i4) :: il_lacode   ! ASCII value of the lower case 'a'
673      INTEGER(i4) :: il_uacode   ! ASCII value of the upper case 'A'
674      INTEGER(i4) :: il_lzcode   ! ASCII value of the lower case 'z'
675
676      ! loop indices
677      INTEGER(i4) :: ji
678      !----------------------------------------------------------------
679
680      il_lacode=ICHAR('a')
681      il_uacode=ICHAR('A')
682      il_lzcode=IACHAR('z')
683
684      cl_var=TRIM(ADJUSTL(cd_var))
685      il_nletter=LEN(TRIM(cl_var))
686      ALLOCATE(cl_tmp(il_nletter))
687      DO ji=1,il_nletter
688         il_icode=IACHAR(cl_var(ji:ji))
689         IF( il_icode >= il_lacode .AND. il_icode <= il_lzcode )THEN
690            ! lower case
691            cl_tmp(ji)=CHAR(il_icode - (il_lacode - il_uacode) )
692         ELSE
693            ! upper case and other character
694            cl_tmp(ji)=CHAR(il_icode)
695         ENDIF
696      ENDDO
697
698      fct_upper=TRIM(ADJUSTL(fct_concat(cl_tmp(:))))
699      DEALLOCATE(cl_tmp)
700
701   END FUNCTION fct_upper
702   !-------------------------------------------------------------------
703   !> @brief This function check if character is numeric.
704   !
705   !> @author J.Paul
706   !> @date November, 2013 - Initial Version
707   !
708   !> @param[in] cd_var character
709   !> @return character is numeric
710   !-------------------------------------------------------------------
711   PURE LOGICAL FUNCTION fct_is_num(cd_var)
712      IMPLICIT NONE
713      ! Argument     
714      CHARACTER(LEN=*), INTENT(IN) :: cd_var
715
716      ! loop indices
717      INTEGER(i4) :: ji
718      !----------------------------------------------------------------
719
720      DO ji=1,LEN(TRIM(cd_var))
721         IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. &
722         &   IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN
723            fct_is_num=.TRUE.
724         ELSE
725            fct_is_num=.FALSE.
726            EXIT
727         ENDIF
728      ENDDO
729
730   END FUNCTION fct_is_num
731   !-------------------------------------------------------------------
732   !> @brief This function check if character is real number.
733   !
734   !> @details
735   !> it allows exponantial and decimal number
736   !> exemple :  1e6, 2.3
737   !>
738   !> @author J.Paul
739   !> @date June, 2015 - Initial Version
740   !
741   !> @param[in] cd_var character
742   !> @return character is numeric
743   !-------------------------------------------------------------------
744   PURE LOGICAL FUNCTION fct_is_real(cd_var)
745      IMPLICIT NONE
746      ! Argument     
747      CHARACTER(LEN=*), INTENT(IN) :: cd_var
748   
749      ! local variables
750      LOGICAL :: ll_exp
751      LOGICAL :: ll_dec
752   
753      ! loop indices
754      INTEGER :: ji
755      !----------------------------------------------------------------
756   
757      ll_exp=.TRUE.
758      ll_dec=.FALSE.
759      DO ji=1,LEN(TRIM(cd_var))
760         IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. &
761         &   IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN
762   
763            fct_is_real=.TRUE.
764            ll_exp=.FALSE.
765     
766         ELSEIF( TRIM(cd_var(ji:ji))=='e' )THEN
767         
768            IF( ll_exp .OR. ji== LEN(TRIM(cd_var)) )THEN
769               fct_is_real=.FALSE.
770               EXIT
771            ELSE
772               ll_exp=.TRUE.
773            ENDIF
774   
775         ELSEIF( TRIM(cd_var(ji:ji))=='.' )THEN
776   
777            IF( ll_dec )THEN
778               fct_is_real=.FALSE.
779               EXIT
780            ELSE
781               fct_is_real=.TRUE.
782               ll_dec=.TRUE.
783            ENDIF
784   
785         ELSE
786   
787            fct_is_real=.FALSE.
788            EXIT
789   
790         ENDIF
791      ENDDO
792   
793   END FUNCTION fct_is_real
794   !-------------------------------------------------------------------
795   !> @brief This function split string of character
796   !> using separator character, by default '|',
797   !> and return the element on index ind.
798   !
799   !> @author J.Paul
800   !> @date November, 2013 - Initial Version
801   !
802   !> @param[in] cd_string string of character
803   !> @param[in] id_ind    indice
804   !> @param[in] cd_sep    separator character
805   !> @return return the element on index id_ind
806   !-------------------------------------------------------------------
807   PURE FUNCTION fct_split(cd_string, id_ind, cd_sep)
808      IMPLICIT NONE
809      ! Argument     
810      CHARACTER(LEN=*), INTENT(IN) :: cd_string
811      INTEGER(i4)     , INTENT(IN) :: id_ind
812      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep
813
814      ! function
815      CHARACTER(LEN=lc) :: fct_split
816
817      ! local variable
818      CHARACTER(LEN=lc) :: cl_sep
819      CHARACTER(LEN=lc) :: cl_string
820
821      INTEGER(i4) :: il_sep
822      INTEGER(i4) :: il_lsep
823     
824      ! loop indices
825      INTEGER(i4) :: ji
826      !----------------------------------------------------------------
827      ! initialize
828      fct_split=''
829      cl_string=ADJUSTL(cd_string)
830
831      ! get separator
832      cl_sep='|'
833      IF( PRESENT(cd_sep) )THEN
834         IF( cd_sep==' ')THEN
835            cl_sep=' '
836         ELSE
837            cl_sep=TRIM(ADJUSTL(cd_sep))
838         ENDIF
839      ENDIF
840     
841      IF( cl_sep /= ' ' )THEN
842         ! get separator index
843         il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
844         il_lsep=LEN(TRIM(cl_sep)) 
845
846         IF( il_sep /= 0 )THEN
847            fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
848         ELSE
849            fct_split=TRIM(ADJUSTL(cl_string))
850         ENDIF
851
852         ji=1
853         DO WHILE( il_sep /= 0 .AND. ji /= id_ind )
854           
855            ji=ji+1
856           
857            cl_string=TRIM(cl_string(il_sep+il_lsep:))
858            il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
859
860            IF( il_sep /= 0 )THEN
861               fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
862            ELSE
863               fct_split=TRIM(ADJUSTL(cl_string))
864            ENDIF
865
866         ENDDO
867
868         IF( ji /= id_ind ) fct_split=''
869      ELSE
870         fct_split=fct__split_space(TRIM(cl_string), id_ind)
871      ENDIF
872
873   END FUNCTION fct_split
874   !-------------------------------------------------------------------
875   !> @brief This function split string of character
876   !> using space as separator,
877   !> and return the element on index ind.
878   !
879   !> @author J.Paul
880   !> @date November, 2013 - Initial Version
881   !
882   !> @param[in] cd_string string of character
883   !> @param[in] id_ind    indice
884   !> @return return the element on index id_ind
885   !-------------------------------------------------------------------
886   PURE FUNCTION fct__split_space(cd_string, id_ind)
887      IMPLICIT NONE
888      ! Argument     
889      CHARACTER(LEN=*), INTENT(IN) :: cd_string
890      INTEGER(i4)     , INTENT(IN) :: id_ind
891
892      ! function
893      CHARACTER(LEN=lc) :: fct__split_space
894
895      ! local variable
896      CHARACTER(LEN=lc) :: cl_string
897
898      INTEGER(i4) :: il_sep
899      INTEGER(i4) :: il_lsep
900     
901      ! loop indices
902      INTEGER(i4) :: ji
903      !----------------------------------------------------------------
904      ! initialize
905      fct__split_space=''
906      cl_string=ADJUSTL(cd_string)
907
908      ! get separator index
909      il_sep=INDEX( TRIM(cl_string), ' ' )
910      il_lsep=LEN(' ') 
911
912      IF( il_sep /= 0 )THEN
913         fct__split_space=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
914      ELSE
915         fct__split_space=TRIM(ADJUSTL(cl_string))
916      ENDIF
917
918      ji=1
919      DO WHILE( il_sep /= 0 .AND. ji /= id_ind )
920         
921         ji=ji+1
922         
923         cl_string=TRIM(cl_string(il_sep+il_lsep:))
924         il_sep=INDEX( TRIM(cl_string), ' ' )
925
926         IF( il_sep /= 0 )THEN
927            fct__split_space=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
928         ELSE
929            fct__split_space=TRIM(ADJUSTL(cl_string))
930         ENDIF
931
932      ENDDO
933
934      IF( ji /= id_ind ) fct__split_space=''
935
936   END FUNCTION fct__split_space
937   !-------------------------------------------------------------------
938   !> @brief This function return basename of a filename.
939   !
940   !> @details
941   !> Actually it splits filename using sperarator '/'
942   !> and return last string character.<br/>
943   !> Optionally you could specify another separator.
944   !> @author J.Paul
945   !> @date November, 2013 - Initial Version
946   !
947   !> @param[in] cd_string filename
948   !> @param[in] cd_sep    separator character
949   !> @return basename (filename without path)
950   !-------------------------------------------------------------------
951   PURE FUNCTION fct_basename(cd_string, cd_sep)
952      IMPLICIT NONE
953      ! Argument     
954      CHARACTER(LEN=*), INTENT(IN) :: cd_string
955      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep
956
957      ! function
958      CHARACTER(LEN=lc) :: fct_basename
959
960      ! local variable
961      CHARACTER(LEN=lc) :: cl_sep
962      CHARACTER(LEN=lc) :: cl_string
963      INTEGER(i4)       :: il_sep
964     
965      ! loop indices
966      !----------------------------------------------------------------
967      ! initialize
968      cl_string=TRIM(ADJUSTL(cd_string))
969
970      ! get separator
971      cl_sep='/'
972      IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep))
973
974      il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.)
975      fct_basename=TRIM(cl_string(il_sep+1:))
976
977   END FUNCTION fct_basename
978   !-------------------------------------------------------------------
979   !> @brief This function return dirname of a filename.
980   !
981   !> @details
982   !> Actually it splits filename using sperarator '/'
983   !> and return all except last string character.<br/>
984   !> Optionally you could specify another separator.
985   !> @author J.Paul
986   !> @date November, 2013 - Initial Version
987   !
988   !> @param[in] cd_string filename
989   !> @param[in] cd_sep    separator character
990   !> @return dirname (path of the filename)
991   !-------------------------------------------------------------------
992   PURE FUNCTION fct_dirname(cd_string, cd_sep)
993      IMPLICIT NONE
994      ! Argument     
995      CHARACTER(LEN=*), INTENT(IN) :: cd_string
996      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep
997
998      ! function
999      CHARACTER(LEN=lc) :: fct_dirname
1000
1001      ! local variable
1002      CHARACTER(LEN=lc) :: cl_sep
1003      CHARACTER(LEN=lc) :: cl_string
1004      INTEGER(i4)       :: il_sep
1005     
1006      ! loop indices
1007      !----------------------------------------------------------------
1008      ! initialize
1009      cl_string=TRIM(ADJUSTL(cd_string))
1010
1011      ! get separator
1012      cl_sep='/'
1013      IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep))
1014
1015      il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.)
1016      IF( il_sep == 0 )THEN
1017         fct_dirname=''
1018      ELSE
1019         fct_dirname=TRIM(cl_string(1:il_sep))
1020      ENDIF
1021
1022   END FUNCTION fct_dirname
1023END MODULE fct
1024
Note: See TracBrowser for help on using the repository browser.