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/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src/function.f90 @ 4213

Last change on this file since 4213 was 4213, checked in by cbricaud, 10 years ago

first draft of the CONFIGURATION MANAGER demonstrator
File size: 24.1 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 group some basic useful function
10!
11!> @author
12!> J.Paul
13! REVISION HISTORY:
14!> @date Nov, 2013 - Initial Version
15!
16!> @todo
17!> - TODO_describe_appropriate_changes - TODO_name
18!> @param MyModule_type : brief_description
19!
20!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
21!----------------------------------------------------------------------
22MODULE fct
23   USE kind                            ! F90 kind parameter
24   IMPLICIT NONE
25   PRIVATE
26   ! NOTE_avoid_public_variables_if_possible
27
28   ! function and subroutine
29   PUBLIC :: OPERATOR(//)
30   PUBLIC :: fct_getunit! returns free unit number
31   PUBLIC :: fct_err    ! handle fortran error status
32   PUBLIC :: fct_str    ! convert numeric to string character
33   PUBLIC :: fct_concat ! concatenate all the element of a character table
34   PUBLIC :: fct_upper  ! convert lower character to upper case
35   PUBLIC :: fct_lower  ! convert upper character to lower case
36   PUBLIC :: fct_is_num ! check if character is numeric
37   PUBLIC :: fct_split  ! split string into substring
38   PUBLIC :: fct_basename ! return basename (name without path)
39   PUBLIC :: fct_dirname ! return dirname (path without name)
40
41   PRIVATE :: fct__i1_str ! convert integer(1) to string character
42   PRIVATE :: fct__i2_str ! convert integer(2) to string character
43   PRIVATE :: fct__i4_str ! convert integer(4) to string character
44   PRIVATE :: fct__i8_str ! convert integer(8) to string character
45   PRIVATE :: fct__r4_str ! convert real(4) to string character
46   PRIVATE :: fct__r8_str ! convert real(8) to string character
47   PRIVATE :: fct__l_str  ! convert logical to string character
48
49
50   INTERFACE fct_str
51      MODULE PROCEDURE fct__i1_str ! convert integer(1) to string character
52      MODULE PROCEDURE fct__i2_str ! convert integer(2) to string character
53      MODULE PROCEDURE fct__i4_str ! convert integer(4) to string character
54      MODULE PROCEDURE fct__i8_str ! convert integer(8) to string character
55      MODULE PROCEDURE fct__r4_str ! convert real(4) to string character
56      MODULE PROCEDURE fct__r8_str ! convert real(8) to string character
57      MODULE PROCEDURE fct__l_str  ! convert logical to string character
58   END INTERFACE fct_str
59
60   INTERFACE OPERATOR(//)
61      MODULE PROCEDURE fct__i4_cat ! concatenate integer(4) to string character
62      MODULE PROCEDURE fct__i8_cat ! concatenate integer(8) to string character
63      MODULE PROCEDURE fct__r4_cat ! concatenate real(4) to string character
64      MODULE PROCEDURE fct__r8_cat ! concatenate real(8) to string character
65      MODULE PROCEDURE fct__l_cat  ! concatenate logical to string character
66   END INTERFACE
67
68CONTAINS
69   !-------------------------------------------------------------------
70   !> @brief This routine concatenate character and integer(4) (as character).
71   !
72   !> @author J.Paul
73   !> - Nov, 2013- Initial Version
74   !
75   !> @return string character
76   !-------------------------------------------------------------------
77   ! @code
78   PURE CHARACTER(LEN=lc) FUNCTION fct__i4_cat(cd_char, id_val) 
79 
80      ! arguments
81      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
82      INTEGER(i4),       INTENT(IN) :: id_val
83
84      ! local variable
85      CHARACTER(LEN=lc) :: cl_val
86      !----------------------------------------------------------------
87 
88      cl_val = fct_str(id_val)
89      fct__i4_cat=TRIM(cd_char)//TRIM(cl_val)
90
91   END FUNCTION fct__i4_cat 
92   ! @endcode
93   !-------------------------------------------------------------------
94   !> @brief This routine concatenate character and integer(8) (as character).
95   !
96   !> @author J.Paul
97   !> - Nov, 2013- Initial Version
98   !
99   !> @return string character
100   !-------------------------------------------------------------------
101   ! @code
102   PURE CHARACTER(LEN=lc) FUNCTION fct__i8_cat(cd_char, kd_val) 
103 
104      ! arguments
105      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
106      INTEGER(i8),       INTENT(IN) :: kd_val
107
108      ! local variable
109      CHARACTER(LEN=lc) :: cl_val
110      !----------------------------------------------------------------
111 
112      cl_val = fct_str(kd_val)
113      fct__i8_cat=TRIM(cd_char)//TRIM(cl_val)
114
115   END FUNCTION fct__i8_cat 
116   ! @endcode
117   !-------------------------------------------------------------------
118   !> @brief This routine concatenate character and real(4) (as character).
119   !
120   !> @author J.Paul
121   !> - Nov, 2013- Initial Version
122   !
123   !> @return string character
124   !-------------------------------------------------------------------
125   ! @code
126   PURE CHARACTER(LEN=lc) FUNCTION fct__r4_cat(cd_char, rd_val) 
127 
128      ! arguments
129      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
130      REAL(sp),          INTENT(IN) :: rd_val
131
132      ! local variable
133      CHARACTER(LEN=lc) :: cl_val
134      !----------------------------------------------------------------
135 
136      cl_val = fct_str(rd_val)
137      fct__r4_cat=TRIM(cd_char)//TRIM(cl_val)
138
139   END FUNCTION fct__r4_cat 
140   ! @endcode
141   !-------------------------------------------------------------------
142   !> @brief This routine concatenate character and real(8) (as character).
143   !
144   !> @author J.Paul
145   !> - Nov, 2013- Initial Version
146   !
147   !> @return string character
148   !-------------------------------------------------------------------
149   ! @code
150   PURE CHARACTER(LEN=lc) FUNCTION fct__r8_cat(cd_char, dd_val) 
151 
152      ! arguments
153      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
154      REAL(dp),          INTENT(IN) :: dd_val
155
156      ! local variable
157      CHARACTER(LEN=lc) :: cl_val
158      !----------------------------------------------------------------
159 
160      cl_val = fct_str(dd_val)
161      fct__r8_cat=TRIM(cd_char)//TRIM(cl_val)
162
163   END FUNCTION fct__r8_cat 
164   ! @endcode
165   !-------------------------------------------------------------------
166   !> @brief This routine concatenate character and logical (as character).
167   !
168   !> @author J.Paul
169   !> - Nov, 2013- Initial Version
170   !
171   !> @return string character
172   !-------------------------------------------------------------------
173   ! @code
174   PURE CHARACTER(LEN=lc) FUNCTION fct__l_cat(cd_char, ld_val) 
175 
176      ! arguments
177      CHARACTER(LEN=lc), INTENT(IN) :: cd_char
178      LOGICAL,           INTENT(IN) :: ld_val
179
180      ! local variable
181      CHARACTER(LEN=lc) :: cl_val
182      !----------------------------------------------------------------
183 
184      cl_val = fct_str(ld_val)
185      fct__l_cat=TRIM(cd_char)//TRIM(cl_val)
186
187   END FUNCTION fct__l_cat 
188   ! @endcode
189   !-------------------------------------------------------------------
190   !> @brief This routine returns the next available I/O unit number.
191   !
192   !> @author J.Paul
193   !> - Nov, 2013- Initial Version
194   !
195   !> @return file id
196   !-------------------------------------------------------------------
197   ! @code
198   INTEGER(i4) FUNCTION fct_getunit() 
199 
200      ! local variable
201      LOGICAL ::  ll_opened 
202      !----------------------------------------------------------------
203      ! initialise
204      fct_getunit = 10 
205 
206      INQUIRE(UNIT=fct_getunit, OPENED=ll_opened) 
207      DO WHILE( ll_opened ) 
208         fct_getunit = fct_getunit + 1 
209         INQUIRE(UNIT=fct_getunit, OPENED=ll_opened) 
210      ENDDO 
211 
212   END FUNCTION fct_getunit 
213   ! @endcode
214   !-------------------------------------------------------------------
215   !> @brief This routine handle Fortran status.
216   !
217   !> @author J.Paul
218   !> - Nov, 2013- Initial Version
219   !-------------------------------------------------------------------
220   ! @code
221   SUBROUTINE fct_err(id_status)
222
223      ! Argument
224      INTEGER(i4),       INTENT(IN) :: id_status
225      !----------------------------------------------------------------
226
227      IF( id_status /= 0 )THEN
228         !CALL ERRSNS() ! not F95 standard
229         PRINT *, "FORTRAN ERROR"
230         !STOP
231      ENDIF
232
233   END SUBROUTINE fct_err
234   ! @endcode
235   !-------------------------------------------------------------------
236   !> @brief This function convert logical to string character.
237   !>
238   !> @author J.Paul
239   !> - Nov, 2013- Initial Version
240   !
241   !> @param[in] ld_var : logical variable
242   !> @return character of this integer variable
243   !-------------------------------------------------------------------
244   ! @code
245   PURE CHARACTER(LEN=lc) FUNCTION fct__l_str(ld_var)
246      IMPLICIT NONE
247      ! Argument     
248      LOGICAL, INTENT(IN) :: ld_var
249
250      ! local variable
251      CHARACTER(LEN=lc) :: cl_tmp
252      !----------------------------------------------------------------
253
254      write(cl_tmp,*) ld_var
255      fct__l_str=TRIM(ADJUSTL(cl_tmp))
256
257   END FUNCTION fct__l_str
258   ! @endcode
259   !-------------------------------------------------------------------
260   !> @brief This function convert integer(1) to string character.
261   !>
262   !> @author J.Paul
263   !> - Nov, 2013- Initial Version
264   !
265   !> @param[in] bd_var : integer(1) variable
266   !> @return character of this integer variable
267   !-------------------------------------------------------------------
268   ! @code
269   PURE CHARACTER(LEN=lc) FUNCTION fct__i1_str(bd_var)
270      IMPLICIT NONE
271      ! Argument     
272      INTEGER(i1), INTENT(IN) :: bd_var
273
274      ! local variable
275      CHARACTER(LEN=lc) :: cl_tmp
276      !----------------------------------------------------------------
277
278      write(cl_tmp,*) bd_var
279      fct__i1_str=TRIM(ADJUSTL(cl_tmp))
280
281   END FUNCTION fct__i1_str
282   ! @endcode
283   !-------------------------------------------------------------------
284   !> @brief This function convert integer(2) to string character.
285   !>
286   !> @author J.Paul
287   !> - Nov, 2013- Initial Version
288   !
289   !> @param[in] sd_var : integer(2) variable
290   !> @return character of this integer variable
291   !-------------------------------------------------------------------
292   ! @code
293   PURE CHARACTER(LEN=lc) FUNCTION fct__i2_str(sd_var)
294      IMPLICIT NONE
295      ! Argument     
296      INTEGER(i2), INTENT(IN) :: sd_var
297
298      ! local variable
299      CHARACTER(LEN=lc) :: cl_tmp
300      !----------------------------------------------------------------
301
302      write(cl_tmp,*) sd_var
303      fct__i2_str=TRIM(ADJUSTL(cl_tmp))
304
305   END FUNCTION fct__i2_str
306   ! @endcode
307   !-------------------------------------------------------------------
308   !> @brief This function convert integer(4) to string character.
309   !>
310   !> @author J.Paul
311   !> - Nov, 2013- Initial Version
312   !
313   !> @param[in] id_var : integer(4) variable
314   !> @return character of this integer variable
315   !-------------------------------------------------------------------
316   ! @code
317   PURE CHARACTER(LEN=lc) FUNCTION fct__i4_str(id_var)
318      IMPLICIT NONE
319      ! Argument     
320      INTEGER(i4), INTENT(IN) :: id_var
321
322      ! local variable
323      CHARACTER(LEN=lc) :: cl_tmp
324      !----------------------------------------------------------------
325
326      write(cl_tmp,*) id_var
327      fct__i4_str=TRIM(ADJUSTL(cl_tmp))
328
329   END FUNCTION fct__i4_str
330   ! @endcode
331   !-------------------------------------------------------------------
332   !> @brief This function convert integer(8) to string character.
333   !>
334   !> @author J.Paul
335   !> - Nov, 2013- Initial Version
336   !
337   !> @param[in] kd_var : integer(8) variable
338   !> @return character of this integer variable
339   !-------------------------------------------------------------------
340   ! @code
341   PURE CHARACTER(LEN=lc) FUNCTION fct__i8_str(kd_var)
342      IMPLICIT NONE
343      ! Argument     
344      INTEGER(i8), INTENT(IN) :: kd_var
345
346      ! local variable
347      CHARACTER(LEN=lc) :: cl_tmp
348      !----------------------------------------------------------------
349
350      write(cl_tmp,*) kd_var
351      fct__i8_str=TRIM(ADJUSTL(cl_tmp))
352
353   END FUNCTION fct__i8_str
354   ! @endcode   
355   !-------------------------------------------------------------------
356   !> @brief This function convert real(4) to string character.
357   !>
358   !> @author J.Paul
359   !> - Nov, 2013- Initial Version
360   !
361   !> @param[in] rd_var : real(4) variable
362   !> @return character of this integer variable
363   !-------------------------------------------------------------------
364   ! @code
365   PURE CHARACTER(LEN=lc) FUNCTION fct__r4_str(rd_var)
366      IMPLICIT NONE
367      ! Argument     
368      REAL(sp), INTENT(IN) :: rd_var
369
370      ! local variable
371      CHARACTER(LEN=lc) :: cl_tmp
372      !----------------------------------------------------------------
373
374      write(cl_tmp,*) rd_var
375      fct__r4_str=TRIM(ADJUSTL(cl_tmp))
376
377   END FUNCTION fct__r4_str
378   ! @endcode   
379   !-------------------------------------------------------------------
380   !> @brief This function convert real(8) to string character.
381   !>
382   !> @author J.Paul
383   !> - Nov, 2013- Initial Version
384   !
385   !> @param[in] dd_var : real(8) variable
386   !> @return character of this integer variable
387   !-------------------------------------------------------------------
388   ! @code
389   PURE CHARACTER(LEN=lc) FUNCTION fct__r8_str(dd_var)
390      IMPLICIT NONE
391      ! Argument     
392      REAL(dp), INTENT(IN) :: dd_var
393
394      ! local variable
395      CHARACTER(LEN=lc) :: cl_tmp
396      !----------------------------------------------------------------
397
398      write(cl_tmp,*) dd_var
399      fct__r8_str=TRIM(ADJUSTL(cl_tmp))
400
401   END FUNCTION fct__r8_str
402   ! @endcode   
403   !-------------------------------------------------------------------
404   !> @brief This function concatenate all the element of a character table
405   !> except unknown one, in a character string.
406   !>
407   !> optionnally a separator could be added between each element
408   !>
409   !> @author J.Paul
410   !> - Nov, 2013- Initial Version
411   !
412   !> @param[in] cd_tab : table of character
413   !> @return character
414   !-------------------------------------------------------------------
415   ! @code
416   PURE CHARACTER(LEN=lc) FUNCTION fct_concat(cd_tab,cd_sep)
417      IMPLICIT NONE
418      ! Argument     
419      CHARACTER(*), DIMENSION(:), INTENT(IN) :: cd_tab
420      CHARACTER(*),               INTENT(IN), OPTIONAL :: cd_sep
421
422      ! local variable
423      CHARACTER(LEN=lc) :: cl_tmp
424      CHARACTER(LEN=lc) :: cl_sep
425      INTEGER(i4)       :: il_size
426
427      ! loop indices
428      INTEGER(i4) :: ji
429      !----------------------------------------------------------------
430
431      cl_sep=''
432      IF(PRESENT(cd_sep)) cl_sep=cd_sep
433
434      il_size=SIZE(cd_tab)
435      fct_concat=''
436      cl_tmp=''
437      DO ji=1,il_size
438
439         !IF( TRIM(ADJUSTL(cd_tab(ji))) /= 'unknown' )THEN
440            WRITE(cl_tmp,*) TRIM(fct_concat)//TRIM(ADJUSTL(cd_tab(ji)))//TRIM(cl_sep)
441         !ENDIF
442     
443         fct_concat=TRIM(ADJUSTL(cl_tmp))
444     
445      ENDDO
446
447   END FUNCTION fct_concat
448   ! @endcode   
449   !-------------------------------------------------------------------
450   !> @brief This function convert string character upper case to lower case.
451   !
452   !> @details
453   !> The function IACHAR returns the ASCII value of the character passed
454   !> as argument. The ASCII code has the uppercase alphabet starting at
455   !> code 65, and the lower case one at code 101, therefore
456   !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase
457   !> and the lowercase codes.
458   !
459   !> @author J.Paul
460   !> - Nov, 2013- Initial Version
461   !
462   !> @param[in] cd_var : character
463   !> @return lower case character
464   !-------------------------------------------------------------------
465   ! @code
466   PURE CHARACTER(LEN=lc) FUNCTION fct_lower(cd_var)
467      IMPLICIT NONE
468      ! Argument     
469      CHARACTER(*), INTENT(IN) :: cd_var
470
471      ! local variable
472      INTEGER(i4)                                  :: il_nletter ! number of letters in variable
473      CHARACTER(LEN=lc)                            :: cl_var
474      CHARACTER(LEN=lc), DIMENSION(:), ALLOCATABLE :: cl_tmp
475
476      INTEGER(i4) :: il_icode    ! ASCII value
477      INTEGER(i4) :: il_lacode   ! ASCII value of the lower case 'a'
478      INTEGER(i4) :: il_uacode   ! ASCII value of the upper case 'A'
479      INTEGER(i4) :: il_uzcode   ! ASCII value of the upper case 'z'
480
481      ! loop indices
482      INTEGER(i4) :: ji
483      !----------------------------------------------------------------
484
485      il_lacode=IACHAR('a')
486      il_uacode=IACHAR('A')
487      il_uzcode=IACHAR('Z')
488
489      cl_var=TRIM(ADJUSTL(cd_var))
490      il_nletter=LEN(TRIM(cl_var))
491      ALLOCATE(cl_tmp(il_nletter))
492      DO ji=1,il_nletter
493         il_icode=IACHAR(cl_var(ji:ji))
494         IF( il_icode >= il_uacode .AND. il_icode <= il_uzcode )THEN
495            ! upper case
496            cl_tmp(ji)=TRIM(CHAR(il_icode + (il_lacode - il_uacode) ))
497         ELSE
498            ! lower case and other character
499            cl_tmp(ji)=TRIM(CHAR(il_icode))
500         ENDIF
501      ENDDO
502
503      fct_lower=TRIM(ADJUSTL(fct_concat(cl_tmp(:))))
504      DEALLOCATE(cl_tmp)
505
506   END FUNCTION fct_lower
507   ! @endcode
508   !-------------------------------------------------------------------
509   !> @brief This function convert string character lower case to upper case.
510   !
511   !> @details
512   !> The function IACHAR returns the ASCII value of the character passed
513   !> as argument. The ASCII code has the uppercase alphabet starting at
514   !> code 65, and the lower case one at code 101, therefore
515   !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase
516   !> and the lowercase codes.
517   !
518   !> @author J.Paul
519   !> - Nov, 2013- Initial Version
520   !
521   !> @param[in] cd_var : character
522   !> @return upper case character
523   !-------------------------------------------------------------------
524   ! @code
525   PURE CHARACTER(LEN=lc) FUNCTION fct_upper(cd_var)
526      IMPLICIT NONE
527      ! Argument     
528      CHARACTER(*), INTENT(IN) :: cd_var
529
530      ! local variable
531      INTEGER(i4)                                  :: il_nletter ! number of letters in cd_var
532      CHARACTER(LEN=lc)                            :: cl_var
533      CHARACTER(LEN=lc), DIMENSION(:), ALLOCATABLE :: cl_tmp
534
535      INTEGER(i4) :: il_icode    ! ASCII value
536      INTEGER(i4) :: il_lacode   ! ASCII value of the lower case 'a'
537      INTEGER(i4) :: il_uacode   ! ASCII value of the upper case 'A'
538      INTEGER(i4) :: il_lzcode   ! ASCII value of the lower case 'z'
539
540      ! loop indices
541      INTEGER(i4) :: ji
542      !----------------------------------------------------------------
543
544      il_lacode=ICHAR('a')
545      il_uacode=ICHAR('A')
546      il_lzcode=IACHAR('z')
547
548      cl_var=TRIM(ADJUSTL(cd_var))
549      il_nletter=LEN(TRIM(cl_var))
550      ALLOCATE(cl_tmp(il_nletter))
551      DO ji=1,il_nletter
552         il_icode=IACHAR(cl_var(ji:ji))
553         IF( il_icode >= il_lacode .AND. il_icode <= il_lzcode )THEN
554            ! lower case
555            cl_tmp(ji)=CHAR(il_icode - (il_lacode - il_uacode) )
556         ELSE
557            ! upper case and other character
558            cl_tmp(ji)=CHAR(il_icode)
559         ENDIF
560      ENDDO
561
562      fct_upper=TRIM(ADJUSTL(fct_concat(cl_tmp(:))))
563      DEALLOCATE(cl_tmp)
564
565   END FUNCTION fct_upper
566   ! @endcode   
567   !-------------------------------------------------------------------
568   !> @brief This function check if character is numeric.
569   !
570   !> @details
571   !
572   !> @author J.Paul
573   !> - Nov, 2013- Initial Version
574   !
575   !> @param[in] cd_var : character
576   !> @return character is numeric
577   !-------------------------------------------------------------------
578   ! @code
579   PURE LOGICAL FUNCTION fct_is_num(cd_var)
580      IMPLICIT NONE
581      ! Argument     
582      CHARACTER(LEN=*), INTENT(IN) :: cd_var
583
584      ! loop indices
585      INTEGER(i4) :: ji
586      !----------------------------------------------------------------
587
588      DO ji=1,LEN(TRIM(cd_var))
589         IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. &
590         &   IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN
591            fct_is_num=.TRUE.
592         ELSE
593            fct_is_num=.FALSE.
594            EXIT
595         ENDIF
596      ENDDO
597
598   END FUNCTION fct_is_num
599   ! @endcode
600   !-------------------------------------------------------------------
601   !> @brief This function split string of character
602   !> using separator character, by default '|',
603   !> and return the element on index ind
604   !
605   !> @details
606   !
607   !> @author J.Paul
608   !> - Nov, 2013- Initial Version
609   !
610   !> @param[in] cd_string : string of character
611   !> @param[in] id_ind : indice
612   !> @param[in] cd_sep   separator character
613   !> @return return the element on index id_ind
614   !-------------------------------------------------------------------
615   ! @code
616   PURE FUNCTION fct_split(cd_string, id_ind, cd_sep)
617      IMPLICIT NONE
618      ! Argument     
619      CHARACTER(LEN=*), INTENT(IN) :: cd_string
620      INTEGER(i4)     , INTENT(IN) :: id_ind
621      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep
622
623      ! function
624      CHARACTER(LEN=lc) :: fct_split
625
626      ! local variable
627      CHARACTER(LEN=lc) :: cl_sep
628      CHARACTER(LEN=lc) :: cl_string
629
630      INTEGER(i4) :: il_sep
631     
632      ! loop indices
633      INTEGER(i4) :: ji
634      !----------------------------------------------------------------
635      ! initialize
636      fct_split=''
637      cl_string=ADJUSTL(cd_string)
638
639      ! get separator
640      cl_sep='|'
641      IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep))
642     
643      ! get separator index
644      il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
645     
646      IF( il_sep /= 0 )THEN
647         fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
648      ELSE
649         fct_split=TRIM(ADJUSTL(cl_string))
650      ENDIF
651
652      ji=1
653      DO WHILE( il_sep /= 0 .AND. ji /= id_ind )
654         
655         ji=ji+1
656         
657         cl_string=TRIM(cl_string(il_sep+1:))
658         il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
659
660         IF( il_sep /= 0 )THEN
661            fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
662         ELSE
663            fct_split=TRIM(ADJUSTL(cl_string))
664         ENDIF
665
666      ENDDO
667
668      IF( ji /= id_ind ) fct_split=''
669
670   END FUNCTION fct_split
671   ! @endcode
672   !-------------------------------------------------------------------
673   !> @brief This function return basename of a filename.
674   !
675   !> @details
676   !> actually it splits filename using sperarator '/'
677   !> and return last string character
678   !
679   !> @author J.Paul
680   !> - Nov, 2013- Initial Version
681   !
682   !> @param[in] cd_string : filename
683   !> @return basename (filename without path)
684   !-------------------------------------------------------------------
685   ! @code
686   PURE FUNCTION fct_basename(cd_string, cd_sep)
687      IMPLICIT NONE
688      ! Argument     
689      CHARACTER(LEN=*), INTENT(IN) :: cd_string
690      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep
691
692      ! function
693      CHARACTER(LEN=lc) :: fct_basename
694
695      ! local variable
696      CHARACTER(LEN=lc) :: cl_sep
697      CHARACTER(LEN=lc) :: cl_string
698      INTEGER(i4)       :: il_sep
699     
700      ! loop indices
701      !----------------------------------------------------------------
702      ! initialize
703      cl_string=TRIM(ADJUSTL(cd_string))
704
705      ! get separator
706      cl_sep='/'
707      IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep))
708
709      il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.)
710      fct_basename=TRIM(cl_string(il_sep+1:))
711
712   END FUNCTION fct_basename
713   ! @endcode
714   !-------------------------------------------------------------------
715   !> @brief This function return dirname of a filename.
716   !
717   !> @details
718   !> actually it splits filename using sperarator '/'
719   !> and return all exept last string character
720   !
721   !> @author J.Paul
722   !> - Nov, 2013- Initial Version
723   !
724   !> @param[in] cd_string : filename
725   !> @return dirname (path of the filename)
726   !-------------------------------------------------------------------
727   ! @code
728   PURE FUNCTION fct_dirname(cd_string, cd_sep)
729      IMPLICIT NONE
730      ! Argument     
731      CHARACTER(LEN=*), INTENT(IN) :: cd_string
732      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sep
733
734      ! function
735      CHARACTER(LEN=lc) :: fct_dirname
736
737      ! local variable
738      CHARACTER(LEN=lc) :: cl_sep
739      CHARACTER(LEN=lc) :: cl_string
740      INTEGER(i4)       :: il_sep
741     
742      ! loop indices
743      !----------------------------------------------------------------
744      ! initialize
745      cl_string=TRIM(ADJUSTL(cd_string))
746
747      ! get separator
748      cl_sep='/'
749      IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep))
750
751      il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.)
752      IF( il_sep == 0 )THEN
753         fct_dirname=''
754      ELSE
755         fct_dirname=TRIM(cl_string(1:il_sep))
756      ENDIF
757
758   END FUNCTION fct_dirname
759   ! @endcode
760END MODULE fct
761
Note: See TracBrowser for help on using the repository browser.