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/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/TOOLS/SIREN/src/function.f90 @ 5600

Last change on this file since 5600 was 5600, checked in by andrewryan, 9 years ago

merged in latest version of trunk alongside changes to SAO_SRC to be compatible with latest OBS

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