|
CP2K 2.4 (Revision 12889)
|
00001 !-----------------------------------------------------------------------------! 00002 ! CP2K: A general program to perform molecular dynamics simulations ! 00003 ! Copyright (C) 2000 - 2013 CP2K developers group ! 00004 !-----------------------------------------------------------------------------! 00005 00006 ! ***************************************************************************** 00012 MODULE input_val_types 00013 USE cp_parser_types, ONLY: default_continuation_character 00014 USE cp_units, ONLY: cp_unit_create,& 00015 cp_unit_desc,& 00016 cp_unit_from_cp2k,& 00017 cp_unit_from_cp2k1,& 00018 cp_unit_release,& 00019 cp_unit_retain,& 00020 cp_unit_type 00021 USE f77_blas 00022 USE input_enumeration_types, ONLY: enum_i2c,& 00023 enum_release,& 00024 enum_retain,& 00025 enumeration_type 00026 USE kinds, ONLY: default_string_length,& 00027 dp 00028 #include "cp_common_uses.h" 00029 00030 IMPLICIT NONE 00031 PRIVATE 00032 00033 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. 00034 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'input_val_types' 00035 00036 INTEGER, SAVE, PRIVATE :: last_val_id=0 00037 00038 PUBLIC :: val_p_type, val_type 00039 PUBLIC :: val_create, val_retain, val_release, val_get, val_write,& 00040 val_write_internal, val_duplicate 00041 !*** 00042 00043 INTEGER, PARAMETER, PUBLIC :: no_t=0, logical_t=1, 00044 integer_t=2, real_t=3, char_t=4, enum_t=5, lchar_t=6 00045 00046 ! ***************************************************************************** 00051 TYPE val_p_type 00052 TYPE(val_type), POINTER :: val 00053 END TYPE val_p_type 00054 00055 ! ***************************************************************************** 00065 TYPE val_type 00066 INTEGER :: ref_count, id_nr, type_of_var 00067 LOGICAL, DIMENSION(:), POINTER :: l_val 00068 INTEGER, DIMENSION(:), POINTER :: i_val 00069 CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: 00070 c_val 00071 REAL(kind=dp), DIMENSION(:), POINTER :: r_val 00072 TYPE(enumeration_type), POINTER :: enum 00073 END TYPE val_type 00074 CONTAINS 00075 00076 ! ***************************************************************************** 00092 SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& 00093 r_val,r_vals,r_vals_ptr,c_val,c_vals,c_vals_ptr,lc_val,lc_vals,& 00094 lc_vals_ptr,enum,error) 00095 TYPE(val_type), POINTER :: val 00096 LOGICAL, INTENT(in), OPTIONAL :: l_val 00097 LOGICAL, DIMENSION(:), INTENT(in), 00098 OPTIONAL :: l_vals 00099 LOGICAL, DIMENSION(:), OPTIONAL, POINTER :: l_vals_ptr 00100 INTEGER, INTENT(in), OPTIONAL :: i_val 00101 INTEGER, DIMENSION(:), INTENT(in), 00102 OPTIONAL :: i_vals 00103 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: i_vals_ptr 00104 REAL(KIND=DP), INTENT(in), OPTIONAL :: r_val 00105 REAL(KIND=DP), DIMENSION(:), 00106 INTENT(in), OPTIONAL :: r_vals 00107 REAL(KIND=DP), DIMENSION(:), OPTIONAL, 00108 POINTER :: r_vals_ptr 00109 CHARACTER(LEN=*), INTENT(in), OPTIONAL :: c_val 00110 CHARACTER(LEN=*), DIMENSION(:), 00111 INTENT(in), OPTIONAL :: c_vals 00112 CHARACTER(LEN=DEFAULT_STRING_LENGTH), 00113 DIMENSION(:), OPTIONAL, POINTER :: c_vals_ptr 00114 CHARACTER(LEN=*), INTENT(in), OPTIONAL :: lc_val 00115 CHARACTER(LEN=*), DIMENSION(:), 00116 INTENT(in), OPTIONAL :: lc_vals 00117 CHARACTER(LEN=DEFAULT_STRING_LENGTH), 00118 DIMENSION(:), OPTIONAL, POINTER :: lc_vals_ptr 00119 TYPE(enumeration_type), OPTIONAL, 00120 POINTER :: enum 00121 TYPE(cp_error_type), INTENT(inout) :: error 00122 00123 CHARACTER(len=*), PARAMETER :: routineN = 'val_create', 00124 routineP = moduleN//':'//routineN 00125 00126 INTEGER :: i, len_c, narg, nVal, stat 00127 LOGICAL :: failure 00128 00129 failure=.FALSE. 00130 00131 CPPrecondition(.NOT.ASSOCIATED(val),cp_failure_level,routineP,error,failure) 00132 ALLOCATE(val,stat=stat) 00133 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00134 IF (.NOT. failure) THEN 00135 NULLIFY(val%l_val,val%i_val,val%r_val,val%c_val,val%enum) 00136 val%type_of_var=no_t 00137 last_val_id=last_val_id+1 00138 val%id_nr=last_val_id 00139 val%ref_count=1 00140 00141 narg=0 00142 val%type_of_var=no_t 00143 IF (PRESENT(l_val)) THEN 00144 !FM CPPrecondition(.NOT.PRESENT(l_vals),cp_failure_level,routineP,error,failure) 00145 !FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,error,failure) 00146 narg=narg+1 00147 ALLOCATE(val%l_val(1),stat=stat) 00148 CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) 00149 val%l_val(1)=l_val 00150 val%type_of_var=logical_t 00151 END IF 00152 IF (PRESENT(l_vals)) THEN 00153 !FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,error,failure) 00154 narg=narg+1 00155 ALLOCATE(val%l_val(SIZE(l_vals)),stat=stat) 00156 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00157 val%l_val=l_vals 00158 val%type_of_var=logical_t 00159 END IF 00160 IF (PRESENT(l_vals_ptr)) THEN 00161 narg=narg+1 00162 val%l_val => l_vals_ptr 00163 val%type_of_var=logical_t 00164 END IF 00165 00166 IF (PRESENT(r_val)) THEN 00167 !FM CPPrecondition(.NOT.PRESENT(r_vals),cp_failure_level,routineP,error,failure) 00168 !FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,error,failure) 00169 narg=narg+1 00170 ALLOCATE(val%r_val(1),stat=stat) 00171 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00172 val%r_val(1)=r_val 00173 val%type_of_var=real_t 00174 END IF 00175 IF (PRESENT(r_vals)) THEN 00176 !FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,error,failure) 00177 narg=narg+1 00178 ALLOCATE(val%r_val(SIZE(r_vals)),stat=stat) 00179 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00180 val%r_val=r_vals 00181 val%type_of_var=real_t 00182 END IF 00183 IF (PRESENT(r_vals_ptr)) THEN 00184 narg=narg+1 00185 val%r_val => r_vals_ptr 00186 val%type_of_var=real_t 00187 END IF 00188 00189 IF (PRESENT(i_val)) THEN 00190 !FM CPPrecondition(.NOT.PRESENT(i_vals),cp_failure_level,routineP,error,failure) 00191 !FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,error,failure) 00192 narg=narg+1 00193 ALLOCATE(val%i_val(1),stat=stat) 00194 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00195 val%i_val(1)=i_val 00196 val%type_of_var=integer_t 00197 END IF 00198 IF (PRESENT(i_vals)) THEN 00199 !FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,error,failure) 00200 narg=narg+1 00201 ALLOCATE(val%i_val(SIZE(i_vals)),stat=stat) 00202 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00203 val%i_val=i_vals 00204 val%type_of_var=integer_t 00205 END IF 00206 IF (PRESENT(i_vals_ptr)) THEN 00207 narg=narg+1 00208 val%i_val => i_vals_ptr 00209 val%type_of_var=integer_t 00210 END IF 00211 00212 IF (PRESENT(c_val)) THEN 00213 CPPrecondition(LEN_TRIM(c_val)<=default_string_length,cp_failure_level,routineP,error,failure) 00214 !FM CPPrecondition(.NOT.PRESENT(c_vals),cp_failure_level,routineP,error,failure) 00215 !FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,error,failure) 00216 narg=narg+1 00217 ALLOCATE(val%c_val(1),stat=stat) 00218 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00219 val%c_val(1)=c_val 00220 val%type_of_var=char_t 00221 END IF 00222 IF (PRESENT(c_vals)) THEN 00223 !FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,error,failure) 00224 CPPrecondition(ALL(LEN_TRIM(c_vals)<=default_string_length),cp_failure_level,routineP,error,failure) 00225 narg=narg+1 00226 ALLOCATE(val%c_val(SIZE(c_vals)),stat=stat) 00227 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00228 val%c_val=c_vals 00229 val%type_of_var=char_t 00230 END IF 00231 IF (PRESENT(c_vals_ptr)) THEN 00232 narg=narg+1 00233 val%c_val => c_vals_ptr 00234 val%type_of_var=char_t 00235 END IF 00236 IF (PRESENT(lc_val)) THEN 00237 !FM CPPrecondition(.NOT.PRESENT(lc_vals),cp_failure_level,routineP,error,failure) 00238 !FM CPPrecondition(.NOT.PRESENT(lc_vals_ptr),cp_failure_level,routineP,error,failure) 00239 narg=narg+1 00240 len_c=LEN_TRIM(lc_val) 00241 nVal=MAX(1,CEILING(REAL(len_c,dp)/80._dp)) 00242 ALLOCATE(val%c_val(nVal),stat=stat) 00243 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00244 00245 IF (len_c == 0) THEN 00246 val%c_val(1) = "" 00247 ELSE 00248 DO i=1,nVal 00249 val%c_val(i)=lc_val((i-1)*default_string_length+1:& 00250 MIN(len_c,i*default_string_length)) 00251 END DO 00252 END IF 00253 val%type_of_var=lchar_t 00254 END IF 00255 IF (PRESENT(lc_vals)) THEN 00256 CPPrecondition(ALL(LEN_TRIM(lc_vals)<=default_string_length),cp_failure_level,routineP,error,failure) 00257 narg=narg+1 00258 ALLOCATE(val%c_val(SIZE(lc_vals)),stat=stat) 00259 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00260 val%c_val=lc_vals 00261 val%type_of_var=lchar_t 00262 END IF 00263 IF (PRESENT(lc_vals_ptr)) THEN 00264 narg=narg+1 00265 val%c_val => lc_vals_ptr 00266 val%type_of_var=lchar_t 00267 END IF 00268 CPPostcondition(narg<=1,cp_failure_level,routineP,error,failure) 00269 IF (PRESENT(enum)) THEN 00270 IF (ASSOCIATED(enum)) THEN 00271 IF (val%type_of_var/=no_t.AND.val%type_of_var/=integer_t.AND.& 00272 val%type_of_var/=enum_t) THEN 00273 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00274 END IF 00275 IF (ASSOCIATED(val%i_val)) THEN 00276 val%type_of_var=enum_t 00277 val%enum=>enum 00278 CALL enum_retain(enum,error=error) 00279 END IF 00280 END IF 00281 END IF 00282 CPPostcondition(ASSOCIATED(val%enum).eqv.val%type_of_var==enum_t,cp_failure_level,routineP,error,failure) 00283 END IF 00284 END SUBROUTINE val_create 00285 00286 ! ***************************************************************************** 00293 SUBROUTINE val_release(val,error) 00294 TYPE(val_type), POINTER :: val 00295 TYPE(cp_error_type), INTENT(inout) :: error 00296 00297 CHARACTER(len=*), PARAMETER :: routineN = 'val_release', 00298 routineP = moduleN//':'//routineN 00299 00300 INTEGER :: stat 00301 LOGICAL :: failure 00302 00303 failure=.FALSE. 00304 00305 IF (ASSOCIATED(val)) THEN 00306 CPPreconditionNoFail(val%ref_count>0,cp_failure_level,routineP,error) 00307 val%ref_count=val%ref_count-1 00308 IF (val%ref_count==0) THEN 00309 IF (ASSOCIATED(val%l_val)) THEN 00310 DEALLOCATE(val%l_val,stat=stat) 00311 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00312 END IF 00313 IF (ASSOCIATED(val%i_val)) THEN 00314 DEALLOCATE(val%i_val,stat=stat) 00315 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00316 END IF 00317 IF (ASSOCIATED(val%r_val)) THEN 00318 DEALLOCATE(val%r_val,stat=stat) 00319 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00320 END IF 00321 IF (ASSOCIATED(val%c_val)) THEN 00322 DEALLOCATE(val%c_val,stat=stat) 00323 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00324 END IF 00325 CALL enum_release(val%enum,error=error) 00326 val%type_of_var=no_t 00327 DEALLOCATE(val,stat=stat) 00328 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00329 END IF 00330 END IF 00331 NULLIFY(val) 00332 END SUBROUTINE val_release 00333 00334 ! ***************************************************************************** 00341 SUBROUTINE val_retain(val,error) 00342 TYPE(val_type), POINTER :: val 00343 TYPE(cp_error_type), INTENT(inout) :: error 00344 00345 CHARACTER(len=*), PARAMETER :: routineN = 'val_retain', 00346 routineP = moduleN//':'//routineN 00347 00348 LOGICAL :: failure 00349 00350 failure=.FALSE. 00351 00352 CPPrecondition(ASSOCIATED(val),cp_failure_level,routineP,error,failure) 00353 IF (.NOT. failure) THEN 00354 CPPreconditionNoFail(val%ref_count>0,cp_failure_level,routineP,error) 00355 val%ref_count=val%ref_count+1 00356 END IF 00357 END SUBROUTINE val_retain 00358 00359 ! ***************************************************************************** 00376 SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& 00377 i_vals,r_val,r_vals,c_val,c_vals,len_c,type_of_var,enum,error) 00378 TYPE(val_type), POINTER :: val 00379 LOGICAL, INTENT(out), OPTIONAL :: has_l, has_i, has_r, has_lc, 00380 has_c, l_val 00381 LOGICAL, DIMENSION(:), OPTIONAL, POINTER :: l_vals 00382 INTEGER, INTENT(out), OPTIONAL :: i_val 00383 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: i_vals 00384 REAL(KIND=DP), INTENT(out), OPTIONAL :: r_val 00385 REAL(KIND=DP), DIMENSION(:), OPTIONAL, 00386 POINTER :: r_vals 00387 CHARACTER(LEN=*), INTENT(out), OPTIONAL :: c_val 00388 CHARACTER(LEN=DEFAULT_STRING_LENGTH), 00389 DIMENSION(:), OPTIONAL, POINTER :: c_vals 00390 INTEGER, INTENT(out), OPTIONAL :: len_c, type_of_var 00391 TYPE(enumeration_type), OPTIONAL, 00392 POINTER :: enum 00393 TYPE(cp_error_type), INTENT(inout) :: error 00394 00395 CHARACTER(len=*), PARAMETER :: routineN = 'val_get', 00396 routineP = moduleN//':'//routineN 00397 00398 INTEGER :: i, l_in, l_out 00399 LOGICAL :: failure 00400 00401 failure=.FALSE. 00402 00403 IF (PRESENT(has_l)) has_l=ASSOCIATED(val%l_val) 00404 IF (PRESENT(has_i)) has_i=ASSOCIATED(val%i_val) 00405 IF (PRESENT(has_r)) has_r=ASSOCIATED(val%r_val) 00406 IF (PRESENT(has_c)) has_c=ASSOCIATED(val%c_val) ! use type_of_var? 00407 IF (PRESENT(has_lc)) has_lc=(val%type_of_var==lchar_t) 00408 IF (PRESENT(l_vals)) l_vals => val%l_val 00409 IF (PRESENT(l_val)) THEN 00410 IF (ASSOCIATED(val%l_val)) THEN 00411 IF (SIZE(val%l_val)>0) THEN 00412 l_val=val%l_val(1) 00413 ELSE 00414 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00415 END IF 00416 ELSE 00417 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00418 END IF 00419 END IF 00420 00421 IF (PRESENT(i_vals)) i_vals => val%i_val 00422 IF (PRESENT(i_val)) THEN 00423 IF (ASSOCIATED(val%i_val)) THEN 00424 IF (SIZE(val%i_val)>0) THEN 00425 i_val=val%i_val(1) 00426 ELSE 00427 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00428 END IF 00429 ELSE 00430 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00431 END IF 00432 END IF 00433 00434 IF (PRESENT(r_vals)) r_vals => val%r_val 00435 IF (PRESENT(r_val)) THEN 00436 IF (ASSOCIATED(val%r_val)) THEN 00437 IF (SIZE(val%r_val)>0) THEN 00438 r_val=val%r_val(1) 00439 ELSE 00440 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00441 END IF 00442 ELSE 00443 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00444 END IF 00445 END IF 00446 00447 IF (PRESENT(c_vals)) c_vals => val%c_val 00448 IF (PRESENT(c_val)) THEN 00449 l_out=LEN(c_val) 00450 IF (ASSOCIATED(val%c_val)) THEN 00451 IF (SIZE(val%c_val)>0) THEN 00452 IF (val%type_of_var==lchar_t) THEN 00453 l_in=default_string_length*(SIZE(val%c_val)-1)+& 00454 LEN_TRIM(val%c_val(SIZE(val%c_val))) 00455 CALL cp_assert(l_out>=l_in,cp_warning_level,cp_assertion_failed,& 00456 routineP,"val_get will truncate value, value beginning with '"//& 00457 TRIM(val%c_val(1))//"' is too long for variable",error,failure) 00458 DO i=1,SIZE(val%c_val) 00459 c_val((i-1)*default_string_length+1:MIN(l_out,i*default_string_length))=& 00460 val%c_val(i)(1:MIN(80,l_out-(i-1)*default_string_length)) 00461 IF (l_out<=i*default_string_length) EXIT 00462 END DO 00463 IF (l_out>SIZE(val%c_val)*default_string_length) & 00464 c_val(SIZE(val%c_val)*default_string_length+1:l_out)="" 00465 ELSE 00466 l_in=LEN_TRIM(val%c_val(1)) 00467 CALL cp_assert(l_out>=l_in,cp_warning_level,cp_assertion_failed,& 00468 routineP,"val_get will truncate value, value '"//& 00469 TRIM(val%c_val(1))//"' is too long for variable",error,failure) 00470 c_val=val%c_val(1) 00471 END IF 00472 ELSE 00473 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00474 END IF 00475 ELSE IF (ASSOCIATED(val%i_val).AND.ASSOCIATED(val%enum)) THEN 00476 IF (SIZE(val%i_val)>0) THEN 00477 c_val=enum_i2c(val%enum,val%i_val(1),error=error) 00478 ELSE 00479 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00480 END IF 00481 ELSE 00482 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00483 END IF 00484 END IF 00485 00486 IF (PRESENT(len_c)) THEN 00487 IF (ASSOCIATED(val%c_val)) THEN 00488 IF (SIZE(val%c_val)>0) THEN 00489 IF (val%type_of_var==lchar_t) THEN 00490 len_c=default_string_length*(SIZE(val%c_val)-1)+& 00491 LEN_TRIM(val%c_val(SIZE(val%c_val))) 00492 ELSE 00493 len_c=LEN_TRIM(val%c_val(1)) 00494 END IF 00495 ELSE 00496 len_c=-HUGE(0) 00497 END IF 00498 ELSE IF (ASSOCIATED(val%i_val).AND.ASSOCIATED(val%enum)) THEN 00499 IF (SIZE(val%i_val)>0) THEN 00500 len_c=LEN_TRIM(enum_i2c(val%enum,val%i_val(1),error=error)) 00501 ELSE 00502 len_c=-HUGE(0) 00503 END IF 00504 ELSE 00505 len_c=-HUGE(0) 00506 END IF 00507 END IF 00508 00509 IF (PRESENT(type_of_var)) type_of_var=val%type_of_var 00510 00511 IF (PRESENT(enum)) enum => val%enum 00512 00513 END SUBROUTINE val_get 00514 00515 ! ***************************************************************************** 00528 SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) 00529 TYPE(val_type), POINTER :: val 00530 INTEGER, INTENT(in) :: unit_nr 00531 TYPE(cp_unit_type), OPTIONAL, POINTER :: unit 00532 CHARACTER(len=*), INTENT(in), OPTIONAL :: unit_str, fmt 00533 TYPE(cp_error_type), INTENT(inout) :: error 00534 00535 CHARACTER(len=*), PARAMETER :: routineN = 'val_write', 00536 routineP = moduleN//':'//routineN 00537 00538 CHARACTER(len=default_string_length) :: c_string, myfmt, rcval 00539 INTEGER :: i, iend, item, j, l 00540 LOGICAL :: failure 00541 TYPE(cp_unit_type), POINTER :: my_unit 00542 00543 failure=.FALSE. 00544 00545 NULLIFY(my_unit) 00546 myfmt = "" 00547 IF (PRESENT(fmt)) myfmt = fmt 00548 IF (PRESENT(unit)) my_unit => unit 00549 IF (ASSOCIATED(my_unit)) THEN 00550 CALL cp_unit_retain(my_unit,error=error) 00551 ELSE IF (PRESENT(unit_str)) THEN 00552 CALL cp_unit_create(my_unit,unit_str,error=error) 00553 END IF 00554 IF (ASSOCIATED(val)) THEN 00555 SELECT CASE(val%type_of_var) 00556 CASE (logical_t) 00557 IF (ASSOCIATED(val%l_val)) THEN 00558 DO i=1,SIZE(val%l_val) 00559 IF (MODULO(i,20)==0) THEN 00560 WRITE(unit=unit_nr,fmt="(' ',A)")default_continuation_character 00561 WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") 00562 END IF 00563 WRITE(unit=unit_nr,fmt="(' ',l1)",advance="NO")& 00564 val%l_val(i) 00565 END DO 00566 ELSE 00567 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00568 END IF 00569 CASE (integer_t) 00570 IF (ASSOCIATED(val%i_val)) THEN 00571 item = 0 00572 i = 1 00573 loop_i: DO WHILE (i <= SIZE(val%i_val)) 00574 item = item + 1 00575 IF (MODULO(item,10) == 0) THEN 00576 WRITE (UNIT=unit_nr,FMT="(1X,A)") default_continuation_character 00577 WRITE (UNIT=unit_nr,FMT="("//TRIM(myfmt)//")",ADVANCE="NO") 00578 END IF 00579 iend = i 00580 loop_j: DO j=i+1,SIZE(val%i_val) 00581 IF (val%i_val(j-1) + 1 == val%i_val(j)) THEN 00582 iend = iend + 1 00583 ELSE 00584 EXIT loop_j 00585 END IF 00586 END DO loop_j 00587 IF ((iend - i) > 1) THEN 00588 WRITE (UNIT=unit_nr,FMT="(1X,I0,A2,I0)",ADVANCE="NO")& 00589 val%i_val(i),"..",val%i_val(iend) 00590 i = iend 00591 ELSE 00592 WRITE (UNIT=unit_nr,FMT="(1X,I0)",ADVANCE="NO")& 00593 val%i_val(i) 00594 END IF 00595 i = i + 1 00596 END DO loop_i 00597 ELSE 00598 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00599 END IF 00600 CASE (real_t) 00601 IF (ASSOCIATED(val%r_val)) THEN 00602 DO i=1,SIZE(val%r_val) 00603 IF (MODULO(i,5)==0) THEN 00604 WRITE(unit=unit_nr,fmt="(' ',A)")default_continuation_character 00605 WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") 00606 END IF 00607 IF (ASSOCIATED(my_unit)) THEN 00608 WRITE(rcval,"(ES25.16)")cp_unit_from_cp2k1(val%r_val(i),my_unit,error=error) 00609 ELSE 00610 WRITE(rcval,"(ES25.16)")val%r_val(i) 00611 END IF 00612 WRITE(unit=unit_nr,fmt="(' ',A)",advance="NO")TRIM(rcval) 00613 END DO 00614 ELSE 00615 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00616 END IF 00617 CASE (char_t) 00618 IF (ASSOCIATED(val%c_val)) THEN 00619 l=0 00620 DO i=1,SIZE(val%c_val) 00621 IF (i>1) WRITE (unit=unit_nr,fmt="(' ')",advance="NO") 00622 l=l+1 00623 IF (l>10.AND.l+LEN_TRIM(val%c_val(i))>76)THEN 00624 WRITE(unit=unit_nr,fmt="('\')") 00625 WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") 00626 l=0 00627 WRITE(unit=unit_nr,fmt='(a)',advance="NO") TRIM(val%c_val(i)) 00628 l=l+LEN_TRIM(val%c_val(i))+3 00629 ELSE IF (LEN_TRIM(val%c_val(i))>0) THEN 00630 l=l+LEN_TRIM(val%c_val(i)) 00631 WRITE(unit=unit_nr,fmt='(a)',advance="NO") TRIM(val%c_val(i)) 00632 ELSE 00633 l=l+3 00634 WRITE (unit=unit_nr,fmt="(a)",advance="NO") '" "' 00635 END IF 00636 END DO 00637 ELSE 00638 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00639 END IF 00640 CASE (lchar_t) 00641 IF (ASSOCIATED(val%c_val)) THEN 00642 l=0 00643 DO i=1,SIZE(val%c_val)-1 00644 WRITE(unit=unit_nr,fmt='(a)',advance="NO") val%c_val(i) 00645 END DO 00646 IF (SIZE(val%c_val)>0) THEN 00647 WRITE(unit=unit_nr,fmt='(a)',advance="NO") TRIM(val%c_val(SIZE(val%c_val))) 00648 END IF 00649 ELSE 00650 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00651 END IF 00652 CASE (enum_t) 00653 IF (ASSOCIATED(val%i_val)) THEN 00654 l=0 00655 DO i=1,SIZE(val%i_val) 00656 c_string=enum_i2c(val%enum,val%i_val(i),error=error) 00657 IF (l>10.AND.l+LEN_TRIM(c_string)>76)THEN 00658 WRITE(unit=unit_nr,fmt="(' ',A)")default_continuation_character 00659 WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") 00660 l=0 00661 ELSE 00662 l=l+LEN_TRIM(c_string)+3 00663 END IF 00664 WRITE(unit=unit_nr,fmt="(' ',a)",advance="NO") TRIM(c_string) 00665 END DO 00666 ELSE 00667 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00668 END IF 00669 00670 CASE(no_t) 00671 WRITE(unit=unit_nr,fmt="(' *empty*')",advance="NO") 00672 CASE default 00673 CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& 00674 routineP,"unexpected type_of_var for val ",error,failure) 00675 END SELECT 00676 ELSE 00677 WRITE(unit=unit_nr,fmt="(' *null*')",advance="NO") 00678 END IF 00679 IF (ASSOCIATED(my_unit)) CALL cp_unit_release(my_unit,error=error) 00680 WRITE(unit=unit_nr,fmt="()") 00681 END SUBROUTINE val_write 00682 00683 ! ***************************************************************************** 00691 SUBROUTINE val_write_internal(val,string,unit,error) 00692 00693 TYPE(val_type), POINTER :: val 00694 CHARACTER(LEN=*), INTENT(OUT) :: string 00695 TYPE(cp_unit_type), OPTIONAL, POINTER :: unit 00696 TYPE(cp_error_type), INTENT(INOUT) :: error 00697 00698 CHARACTER(len=*), PARAMETER :: routineN = 'val_write_internal', 00699 routineP = moduleN//':'//routineN 00700 00701 CHARACTER(LEN=default_string_length) :: enum_string 00702 INTEGER :: i, ipos 00703 LOGICAL :: failure 00704 REAL(KIND=dp) :: value 00705 00706 ! ------------------------------------------------------------------------- 00707 00708 failure = .FALSE. 00709 00710 string = "" 00711 00712 IF (ASSOCIATED(val)) THEN 00713 00714 SELECT CASE(val%type_of_var) 00715 CASE (logical_t) 00716 IF (ASSOCIATED(val%l_val)) THEN 00717 DO i=1,SIZE(val%l_val) 00718 WRITE (UNIT=string(2*i-1:),FMT="(L2)") val%l_val(i) 00719 END DO 00720 ELSE 00721 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00722 END IF 00723 CASE (integer_t) 00724 IF (ASSOCIATED(val%i_val)) THEN 00725 DO i=1,SIZE(val%i_val) 00726 WRITE (UNIT=string(12*i-11:),FMT="(I12)") val%i_val(i) 00727 END DO 00728 ELSE 00729 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00730 END IF 00731 CASE (real_t) 00732 IF (ASSOCIATED(val%r_val)) THEN 00733 IF (PRESENT(unit)) THEN 00734 DO i=1,SIZE(val%r_val) 00735 value = cp_unit_from_cp2k(value=val%r_val(i),& 00736 unit_str=cp_unit_desc(unit=unit,& 00737 error=error),& 00738 error=error) 00739 WRITE (UNIT=string(16*i-15:),FMT="(ES16.8)") value 00740 END DO 00741 ELSE 00742 DO i=1,SIZE(val%r_val) 00743 WRITE (UNIT=string(16*i-15:),FMT="(ES16.8)") val%r_val(i) 00744 END DO 00745 END IF 00746 ELSE 00747 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00748 END IF 00749 CASE (char_t) 00750 IF (ASSOCIATED(val%c_val)) THEN 00751 ipos = 1 00752 DO i=1,SIZE(val%c_val) 00753 WRITE (UNIT=string(ipos:),FMT="(A)") TRIM(ADJUSTL(val%c_val(i))) 00754 ipos = ipos + LEN_TRIM(ADJUSTL(val%c_val(i))) + 1 00755 END DO 00756 ELSE 00757 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00758 END IF 00759 CASE (lchar_t) 00760 IF (ASSOCIATED(val%c_val)) THEN 00761 CALL val_get(val,c_val=string,error=error) 00762 ELSE 00763 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00764 END IF 00765 CASE (enum_t) 00766 IF (ASSOCIATED(val%i_val)) THEN 00767 DO i=1,SIZE(val%i_val) 00768 enum_string = enum_i2c(val%enum,val%i_val(i),error) 00769 WRITE (UNIT=string,FMT="(A)") TRIM(ADJUSTL(enum_string)) 00770 END DO 00771 ELSE 00772 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00773 END IF 00774 CASE default 00775 CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& 00776 routineP,"unexpected type_of_var for val ",error,& 00777 failure) 00778 END SELECT 00779 00780 END IF 00781 00782 END SUBROUTINE val_write_internal 00783 00784 ! ***************************************************************************** 00792 SUBROUTINE val_duplicate(val_in,val_out,error) 00793 TYPE(val_type), POINTER :: val_in, val_out 00794 TYPE(cp_error_type), INTENT(inout) :: error 00795 00796 CHARACTER(len=*), PARAMETER :: routineN = 'val_duplicate', 00797 routineP = moduleN//':'//routineN 00798 00799 INTEGER :: stat 00800 LOGICAL :: failure 00801 00802 failure=.FALSE. 00803 CPPrecondition(ASSOCIATED(val_in),cp_failure_level,routineP,error,failure) 00804 CPPrecondition(.NOT.ASSOCIATED(val_out),cp_failure_level,routineP,error,failure) 00805 IF (.NOT. failure) THEN 00806 ALLOCATE(val_out,stat=stat) 00807 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00808 END IF 00809 IF (.NOT.failure) THEN 00810 last_val_id=last_val_id+1 00811 val_out%id_nr=last_val_id 00812 val_out%type_of_var=val_in%type_of_var 00813 val_out%ref_count=1 00814 val_out%enum => val_in%enum 00815 IF (ASSOCIATED(val_out%enum)) CALL enum_retain(val_out%enum,error=error) 00816 00817 NULLIFY(val_out%l_val,val_out%i_val,val_out%c_val,val_out%r_val) 00818 IF (ASSOCIATED(val_in%l_val)) THEN 00819 ALLOCATE(val_out%l_val(SIZE(val_in%l_val)),stat=stat) 00820 CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) 00821 val_out%l_val=val_in%l_val 00822 END IF 00823 IF (ASSOCIATED(val_in%i_val)) THEN 00824 ALLOCATE(val_out%i_val(SIZE(val_in%i_val)),stat=stat) 00825 CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) 00826 val_out%i_val=val_in%i_val 00827 END IF 00828 IF (ASSOCIATED(val_in%r_val)) THEN 00829 ALLOCATE(val_out%r_val(SIZE(val_in%r_val)),stat=stat) 00830 CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) 00831 val_out%r_val=val_in%r_val 00832 END IF 00833 IF (ASSOCIATED(val_in%c_val)) THEN 00834 ALLOCATE(val_out%c_val(SIZE(val_in%c_val)),stat=stat) 00835 CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) 00836 val_out%c_val=val_in%c_val 00837 END IF 00838 END IF 00839 END SUBROUTINE val_duplicate 00840 00841 END MODULE input_val_types
1.7.3