/[lmdze]/trunk/IOIPSL/getincom2.f
ViewVC logotype

Diff of /trunk/IOIPSL/getincom2.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 51 by guez, Tue Sep 20 09:14:34 2011 UTC revision 72 by guez, Tue Jul 23 13:00:07 2013 UTC
# Line 410  CONTAINS Line 410  CONTAINS
410    
411    !****************************    !****************************
412    
   SUBROUTINE getfilc(MY_TARGET, status, fileorig, ret_val)  
   
     ! Subroutine that will extract from the file the values  
     ! attributed to the keyword MY_TARGET  
     
     ! CHARACTER  
     ! ---------  
     
     ! MY_TARGET   : in  : CHARACTER(LEN=*)  target for which we will  
     !                                    look in the file  
     ! status   : out : INTEGER tells us from where we obtained the data  
     ! fileorig : out : The index of the file from which the key comes  
     ! ret_val  : out : CHARACTER(nb_to_ret) values read  
   
     
     use strlowercase_m, only: strlowercase  
     
     CHARACTER(LEN=*) :: MY_TARGET  
     INTEGER :: status, fileorig  
     CHARACTER(LEN=*), DIMENSION(:) :: ret_val  
     
     INTEGER :: nb_to_ret  
     INTEGER :: it, pos, len_str, status_cnt  
     CHARACTER(LEN=3)  :: cnt  
     CHARACTER(LEN=30) :: full_target  
     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp  
     INTEGER :: full_target_sig  
     
     INTEGER, SAVE :: max_len = 0  
     LOGICAL, DIMENSION(:), SAVE, ALLOCATABLE :: found  
     LOGICAL :: def_beha  
   
     nb_to_ret = SIZE(ret_val)  
     CALL getin_read  
     
     ! Get the variables and memory we need  
     
     IF (max_len == 0) THEN  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     IF (max_len < nb_to_ret) THEN  
        DEALLOCATE(found)  
        ALLOCATE(found(nb_to_ret))  
        max_len = nb_to_ret  
     ENDIF  
     found(:) = .FALSE.  
     
     ! See what we find in the files read  
     
     DO it=1, nb_to_ret  
   
        ! First try the target as it is  
        full_target = MY_TARGET(1:len_TRIM(MY_TARGET))  
        CALL gensig (full_target, full_target_sig)  
        CALL find_sig (nb_lines, targetlist, full_target, &  
             &                 targetsiglist, full_target_sig, pos)  
   
        ! Another try  
   
        IF (pos < 0) THEN  
           WRITE(cnt, '(I3.3)') it  
           full_target = MY_TARGET(1:len_TRIM(MY_TARGET))//'__'//cnt  
           CALL gensig (full_target, full_target_sig)  
           CALL find_sig (nb_lines, targetlist, full_target, &  
                &                   targetsiglist, full_target_sig, pos)  
        ENDIF  
   
        ! A priori we dont know from which file the target could come.  
        ! Thus by default we attribute it to the first file :  
   
        fileorig = 1  
   
        IF (pos > 0) THEN  
   
           found(it) = .TRUE.  
           fileorig = fromfile(pos)  
   
           ! DECODE  
   
           str_READ = TRIM(ADJUSTL(fichier(pos)))  
           str_READ_lower = str_READ  
           CALL strlowercase (str_READ_lower)  
   
           IF (    (     (INDEX(str_READ_lower, 'def') == 1)     &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &  
                &        .OR.(     (INDEX(str_READ_lower, 'default') == 1) &  
                &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN  
              def_beha = .TRUE.  
           ELSE  
              def_beha = .FALSE.  
              len_str = LEN_TRIM(str_READ)  
              ret_val(it) = str_READ(1:len_str)  
           ENDIF  
   
           targetsiglist(pos) = -1  
   
        ELSE  
           found(it) = .FALSE.  
        ENDIF  
     ENDDO  
     
     ! Now we get the status for what we found  
     
     IF (def_beha) THEN  
        status = 2  
        WRITE(*, *) 'USING DEFAULT BEHAVIOUR FOR ', TRIM(MY_TARGET)  
     ELSE  
        status_cnt = 0  
        DO it=1, nb_to_ret  
           IF (.NOT. found(it)) THEN  
              status_cnt = status_cnt+1  
              IF (nb_to_ret > 1) THEN  
                 WRITE(str_tmp, '(a, "__", I3.3)') TRIM(MY_TARGET), it  
              ELSE  
                 str_tmp = MY_TARGET(1:len_TRIM(MY_TARGET))  
              ENDIF  
              WRITE(*, *) 'USING DEFAULTS : ', TRIM(str_tmp), '=', ret_val(it)  
           ENDIF  
        ENDDO  
       
        IF (status_cnt == 0) THEN  
           status = 1  
        ELSE IF (status_cnt == nb_to_ret) THEN  
           status = 2  
        ELSE  
           status = 3  
        ENDIF  
     ENDIF  
   
   END SUBROUTINE getfilc  
   
   !****************************  
   
413    SUBROUTINE getfill(MY_TARGET, status, fileorig, ret_val)    SUBROUTINE getfill(MY_TARGET, status, fileorig, ret_val)
414    
415      ! Subroutine that will extract from the file the values      ! Subroutine that will extract from the file the values
# Line 1310  CONTAINS Line 1176  CONTAINS
1176    
1177    END SUBROUTINE getdbrr    END SUBROUTINE getdbrr
1178    
   !=== CHARACTER database INTERFACE  
   
   SUBROUTINE getdbwc &  
        & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)  
   
     ! Write the CHARACTER data into the data base  
   
     
     CHARACTER(LEN=*) :: MY_TARGET  
     INTEGER :: target_sig, status, fileorig, size_of_in  
     CHARACTER(LEN=*), DIMENSION(:) :: tmp_ret_val  
   
     
     ! First check if we have sufficiant space for the new key  
     
     IF (nb_keys+1 > keymemsize) THEN  
        CALL getin_allockeys ()  
     ENDIF  
     
     ! Fill out the items of the data base  
     
     nb_keys = nb_keys+1  
     keysig(nb_keys) = target_sig  
     keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))  
     keystatus(nb_keys) = status  
     keytype(nb_keys) = 3  
     keyfromfile(nb_keys) = fileorig  
     keymemstart(nb_keys) = charmempos+1  
     keymemlen(nb_keys) = size_of_in  
     
     ! Before writing the actual size lets see if we have the space  
     
     IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN  
        CALL getin_allocmem (3, keymemlen(nb_keys))  
     ENDIF  
     
     charmem(keymemstart(nb_keys): &  
          &        keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &  
          &  tmp_ret_val(1:keymemlen(nb_keys))  
     charmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1  
   
   END SUBROUTINE getdbwc  
   
   !****************************  
   
   SUBROUTINE getdbrc(pos, size_of_in, MY_TARGET, tmp_ret_val)  
   
     ! Read the required variables in the database for CHARACTER  
   
     
     INTEGER :: pos, size_of_in  
     CHARACTER(LEN=*) :: MY_TARGET  
     CHARACTER(LEN=*), DIMENSION(:) :: tmp_ret_val  
   
     IF (keytype(pos) /= 3) THEN  
        WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET  
        STOP 'getdbrc'  
     ENDIF  
     
     IF (keymemlen(pos) /= size_of_in) THEN  
        WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET  
        STOP 'getdbrc'  
     ELSE  
        tmp_ret_val(1:size_of_in) = &  
             &    charmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)  
     ENDIF  
   
   END SUBROUTINE getdbrc  
   
1179    !=== LOGICAL database INTERFACE    !=== LOGICAL database INTERFACE
1180    
1181    SUBROUTINE getdbwl &    SUBROUTINE getdbwl &
Legend:
Removed from v.51  
changed lines
  Added in v.72
  ViewVC Help
Powered by ViewVC 1.1.21