|
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 #define CP_SLL_C_LESS_Q(el1,el2,error) ( el1 < el2 ) 00007 #define CP_SLL_C_EQUAL_Q(el1,el2,error) ( el1 == el2 ) 00008 00009 00010 ! ***************************************************************************** 00046 MODULE cp_linked_list_char 00047 USE f77_blas 00048 USE kinds, ONLY: default_string_length 00049 #include "cp_common_uses.h" 00050 00051 IMPLICIT NONE 00052 PRIVATE 00053 00054 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. 00055 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_linked_list_char' 00056 00057 ! type 00058 PUBLIC :: cp_sll_char_type, cp_sll_char_p_type 00059 ! common methods 00060 PUBLIC :: cp_create, cp_dealloc, cp_get, cp_set, cp_next 00061 ! special get 00062 PUBLIC :: cp_get_first_el, cp_get_rest, cp_get_empty, cp_get_length,& 00063 cp_get_element_at, cp_to_array 00064 ! special set 00065 PUBLIC :: cp_set_element_at 00066 ! structure manipulation 00067 PUBLIC :: cp_insert, cp_remove_first_el, cp_remove_el, cp_remove_all 00068 ! low level 00069 PUBLIC :: cp_dealloc_node 00070 00071 ! underlying routines 00072 PUBLIC :: cp_sll_char_create, cp_sll_char_dealloc,& 00073 cp_sll_char_dealloc_node,cp_sll_char_set,& 00074 cp_sll_char_get,cp_sll_char_next,& 00075 cp_sll_char_get_first_el, cp_sll_char_get_rest,& 00076 cp_sll_char_get_empty, cp_sll_char_get_length,& 00077 cp_sll_char_get_el_at, cp_sll_char_set_el_at,& 00078 cp_sll_char_insert_el, cp_sll_char_insert_el_at,& 00079 cp_sll_char_rm_first_el, cp_sll_char_rm_el_at,& 00080 cp_sll_char_rm_all_el, & 00081 cp_sll_char_to_array,& 00082 cp_sll_char_from_array, cp_sll_char_insert_ordered,& 00083 cp_sll_char_insert_ordered2 00084 00085 ! creation of an object (from a pointer) 00086 INTERFACE cp_create 00087 MODULE PROCEDURE cp_sll_char_create 00088 END INTERFACE 00089 ! destruction of an object (from a pointer) 00090 INTERFACE cp_dealloc 00091 MODULE PROCEDURE cp_sll_char_dealloc 00092 END INTERFACE 00093 ! destruction only of the node (low level) 00094 INTERFACE cp_dealloc_node 00095 MODULE PROCEDURE cp_sll_char_dealloc_node 00096 END INTERFACE 00097 ! modifies attributes of an object 00098 INTERFACE cp_set 00099 MODULE PROCEDURE cp_sll_char_set 00100 END INTERFACE 00101 ! returns attributes of an object 00102 INTERFACE cp_get 00103 MODULE PROCEDURE cp_sll_char_get 00104 END INTERFACE 00105 ! iterates to the next element 00106 INTERFACE cp_next 00107 MODULE PROCEDURE cp_sll_char_next 00108 END INTERFACE 00109 ! returns the first element 00110 INTERFACE cp_get_first_el 00111 MODULE PROCEDURE cp_sll_char_get_first_el 00112 END INTERFACE 00113 ! returns the rest of the list 00114 INTERFACE cp_get_rest 00115 MODULE PROCEDURE cp_sll_char_get_rest 00116 END INTERFACE 00117 ! returns if the list is empty 00118 INTERFACE cp_get_empty 00119 MODULE PROCEDURE cp_sll_char_get_empty 00120 END INTERFACE 00121 ! returns the length of the list 00122 INTERFACE cp_get_length 00123 MODULE PROCEDURE cp_sll_char_get_length 00124 END INTERFACE 00125 ! returns the element at the given position 00126 INTERFACE cp_get_element_at 00127 MODULE PROCEDURE cp_sll_char_get_el_at 00128 END INTERFACE 00129 ! sets the element at the given position 00130 INTERFACE cp_set_element_at 00131 MODULE PROCEDURE cp_sll_char_set_el_at 00132 END INTERFACE 00133 ! inserts one element call cp_insert(list,element,...) 00134 INTERFACE cp_insert 00135 MODULE PROCEDURE cp_sll_char_insert_el 00136 END INTERFACE 00137 !MK INTERFACE cp_insert_ordered 00138 !MK MODULE PROCEDURE cp_sll_char_insert_ordered,& 00139 !MK cp_sll_char_insert_ordered2 00140 !MK END INTERFACE 00141 INTERFACE cp_insert_at 00142 MODULE PROCEDURE cp_sll_char_insert_el_at 00143 END INTERFACE 00144 ! removes an element 00145 INTERFACE cp_remove_el 00146 MODULE PROCEDURE cp_sll_char_rm_first_el, & 00147 cp_sll_char_rm_el_at 00148 END INTERFACE 00149 ! removes the first el 00150 INTERFACE cp_remove_first_el 00151 MODULE PROCEDURE cp_sll_char_rm_first_el 00152 END INTERFACE 00153 ! remove all the elments 00154 INTERFACE cp_remove_all 00155 MODULE PROCEDURE cp_sll_char_rm_all_el 00156 END INTERFACE 00157 ! transorms the list in array 00158 INTERFACE cp_to_array 00159 MODULE PROCEDURE cp_sll_char_to_array 00160 END INTERFACE 00161 00162 ! ***************************************************************************** 00184 TYPE cp_sll_char_type 00185 CHARACTER(len=default_string_length) :: first_el 00186 TYPE(cp_sll_char_type), POINTER :: rest 00187 END TYPE cp_sll_char_type 00188 00189 ! ***************************************************************************** 00196 TYPE cp_sll_char_p_type 00197 TYPE(cp_sll_char_type), POINTER :: list 00198 END TYPE cp_sll_char_p_type 00199 00200 CONTAINS 00201 00202 SUBROUTINE write_string(str,unit_nr,error) 00203 CHARACTER(len=*), INTENT(in) :: str 00204 INTEGER, INTENT(in) :: unit_nr 00205 TYPE(cp_error_type), INTENT(inout) :: error 00206 00207 WRITE(unit_nr,"(a,a,a)") '"',TRIM(str),'"' 00208 END SUBROUTINE write_string 00209 00210 ! =========== creation / distruction ======== 00211 00212 ! ***************************************************************************** 00223 SUBROUTINE cp_sll_char_create(sll,first_el,rest,error) 00224 TYPE(cp_sll_char_type), POINTER :: sll 00225 CHARACTER(len=default_string_length), 00226 INTENT(in), OPTIONAL :: first_el 00227 TYPE(cp_sll_char_type), OPTIONAL, 00228 POINTER :: rest 00229 TYPE(cp_error_type), INTENT(inout) :: error 00230 00231 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_create', 00232 routineP = moduleN//':'//routineN 00233 00234 INTEGER :: stat 00235 LOGICAL :: failure 00236 00237 failure=.FALSE. 00238 00239 IF (.NOT.PRESENT(first_el)) THEN 00240 NULLIFY(sll) 00241 IF (PRESENT(rest)) sll => rest 00242 ELSE 00243 ALLOCATE(sll, stat=stat) 00244 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00245 IF (.NOT.failure) THEN 00246 sll%first_el = first_el 00247 NULLIFY(sll%rest) 00248 IF (PRESENT(rest)) sll%rest => rest 00249 END IF 00250 END IF 00251 IF (failure) NULLIFY(sll) 00252 END SUBROUTINE cp_sll_char_create 00253 00254 ! ***************************************************************************** 00267 SUBROUTINE cp_sll_char_dealloc(sll,error) 00268 TYPE(cp_sll_char_type), POINTER :: sll 00269 TYPE(cp_error_type), INTENT(inout) :: error 00270 00271 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_dealloc', 00272 routineP = moduleN//':'//routineN 00273 00274 CALL cp_sll_char_rm_all_el(sll,error) 00275 END SUBROUTINE cp_sll_char_dealloc 00276 00277 ! * low-level * 00278 00279 ! ***************************************************************************** 00288 SUBROUTINE cp_sll_char_dealloc_node(sll,error) 00289 TYPE(cp_sll_char_type), POINTER :: sll 00290 TYPE(cp_error_type), INTENT(inout) :: error 00291 00292 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_dealloc_node', 00293 routineP = moduleN//':'//routineN 00294 00295 INTEGER :: stat 00296 LOGICAL :: failure 00297 00298 failure=.FALSE. 00299 00300 DEALLOCATE(sll, stat=stat) 00301 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00302 END SUBROUTINE cp_sll_char_dealloc_node 00303 00304 ! ============= get/set ============ 00305 00306 ! ***************************************************************************** 00319 SUBROUTINE cp_sll_char_set(sll,first_el,rest,error) 00320 TYPE(cp_sll_char_type), POINTER :: sll 00321 CHARACTER(len=default_string_length), 00322 INTENT(in), OPTIONAL :: first_el 00323 TYPE(cp_sll_char_type), OPTIONAL, 00324 POINTER :: rest 00325 TYPE(cp_error_type), INTENT(inout) :: error 00326 00327 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_set', 00328 routineP = moduleN//':'//routineN 00329 00330 LOGICAL :: failure 00331 00332 failure=.FALSE. 00333 00334 IF (.NOT.ASSOCIATED(sll)) THEN 00335 IF (PRESENT(first_el)) THEN 00336 CALL cp_sll_char_create(sll,first_el,rest,error) 00337 ELSE 00338 CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) 00339 END IF 00340 ELSE 00341 IF (PRESENT(first_el)) sll%first_el = first_el 00342 IF (PRESENT(rest)) sll%rest => rest 00343 END IF 00344 END SUBROUTINE cp_sll_char_set 00345 00346 ! ***************************************************************************** 00358 SUBROUTINE cp_sll_char_get(sll,first_el,rest,empty,length,error) 00359 TYPE(cp_sll_char_type), POINTER :: sll 00360 CHARACTER(len=default_string_length), 00361 INTENT(out), OPTIONAL :: first_el 00362 TYPE(cp_sll_char_type), OPTIONAL, 00363 POINTER :: rest 00364 LOGICAL, INTENT(out), OPTIONAL :: empty 00365 INTEGER, INTENT(out), OPTIONAL :: length 00366 TYPE(cp_error_type), INTENT(inout) :: error 00367 00368 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get', 00369 routineP = moduleN//':'//routineN 00370 00371 LOGICAL :: failure 00372 00373 failure=.FALSE. 00374 00375 IF (.NOT.ASSOCIATED(sll)) THEN 00376 CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) 00377 IF (PRESENT(rest)) NULLIFY(rest) 00378 IF (PRESENT(empty)) empty=.TRUE. 00379 IF (PRESENT(length)) length=0 00380 ELSE 00381 IF (PRESENT(first_el)) first_el = sll%first_el 00382 IF (PRESENT(rest)) rest => sll%rest 00383 IF (PRESENT(empty)) empty = .FALSE. 00384 IF (PRESENT(length)) & 00385 length = cp_sll_char_get_length(sll,error=error) 00386 END IF 00387 END SUBROUTINE cp_sll_char_get 00388 00389 ! ***************************************************************************** 00398 FUNCTION cp_sll_char_get_first_el(sll,error) RESULT(res) 00399 TYPE(cp_sll_char_type), POINTER :: sll 00400 TYPE(cp_error_type), INTENT(inout) :: error 00401 CHARACTER(len=default_string_length) :: res 00402 00403 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_first_el', 00404 routineP = moduleN//':'//routineN 00405 00406 LOGICAL :: failure 00407 00408 failure=.FALSE. 00409 00410 IF (cp_debug) THEN 00411 CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) 00412 END IF 00413 IF (.NOT. failure) THEN 00414 res = sll%first_el 00415 END IF 00416 END FUNCTION cp_sll_char_get_first_el 00417 00418 ! ***************************************************************************** 00431 FUNCTION cp_sll_char_get_rest(sll, iter, error) RESULT(res) 00432 TYPE(cp_sll_char_type), POINTER :: sll 00433 INTEGER, OPTIONAL :: iter 00434 TYPE(cp_error_type), INTENT(inout) :: error 00435 TYPE(cp_sll_char_type), POINTER :: res 00436 00437 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_rest', 00438 routineP = moduleN//':'//routineN 00439 00440 INTEGER :: i 00441 LOGICAL :: failure 00442 00443 failure=.FALSE. 00444 00445 IF (.NOT.ASSOCIATED(sll)) THEN 00446 NULLIFY(res) 00447 ELSE 00448 IF (.NOT. failure) THEN 00449 IF (PRESENT(iter)) THEN 00450 res => sll 00451 DO i=1,iter 00452 IF (ASSOCIATED(res%rest)) THEN 00453 res => res%rest 00454 ELSE 00455 CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& 00456 routineP, "tried to go past end in "// & 00457 CPSourceFileRef,& 00458 error,failure) 00459 END IF 00460 END DO 00461 IF (iter==-1) THEN 00462 DO 00463 IF (.NOT.ASSOCIATED(res%rest)) EXIT 00464 res => res%rest 00465 END DO 00466 END IF 00467 ELSE 00468 res => sll%rest ! make the common case fast... 00469 END IF 00470 ELSE 00471 NULLIFY(res) 00472 END IF 00473 END IF 00474 END FUNCTION cp_sll_char_get_rest 00475 00476 ! ***************************************************************************** 00484 FUNCTION cp_sll_char_get_empty(sll,error) RESULT(res) 00485 TYPE(cp_sll_char_type), POINTER :: sll 00486 TYPE(cp_error_type), INTENT(inout) :: error 00487 LOGICAL :: res 00488 00489 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_empty', 00490 routineP = moduleN//':'//routineN 00491 00492 LOGICAL :: failure 00493 00494 failure=.FALSE. 00495 00496 res = .NOT.ASSOCIATED(sll) 00497 END FUNCTION cp_sll_char_get_empty 00498 00499 ! ***************************************************************************** 00510 FUNCTION cp_sll_char_get_length(sll,error) RESULT(res) 00511 TYPE(cp_sll_char_type), POINTER :: sll 00512 TYPE(cp_error_type), INTENT(inout) :: error 00513 INTEGER :: res 00514 00515 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_length', 00516 routineP = moduleN//':'//routineN 00517 00518 LOGICAL :: failure 00519 TYPE(cp_sll_char_type), POINTER :: iterator 00520 00521 failure=.FALSE. 00522 00523 res=0 00524 iterator => sll 00525 DO 00526 IF (ASSOCIATED(iterator)) THEN 00527 res=res+1 00528 iterator => iterator%rest 00529 ELSE 00530 EXIT 00531 END IF 00532 END DO 00533 END FUNCTION cp_sll_char_get_length 00534 00535 ! ***************************************************************************** 00547 FUNCTION cp_sll_char_get_el_at(sll,index,error) RESULT(res) 00548 TYPE(cp_sll_char_type), POINTER :: sll 00549 INTEGER, INTENT(in) :: index 00550 TYPE(cp_error_type), INTENT(inout) :: error 00551 CHARACTER(len=default_string_length) :: res 00552 00553 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_el_at', 00554 routineP = moduleN//':'//routineN 00555 00556 LOGICAL :: failure 00557 TYPE(cp_sll_char_type), POINTER :: pos 00558 00559 failure=.FALSE. 00560 00561 IF (cp_debug) THEN 00562 CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) 00563 END IF 00564 IF (index==-1) THEN 00565 pos => cp_sll_char_get_rest(sll, iter=-1,error=error) 00566 ELSE 00567 pos => cp_sll_char_get_rest(sll, iter=index-1,error=error) 00568 END IF 00569 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00570 IF (.NOT.failure) THEN 00571 res = pos%first_el 00572 END IF 00573 END FUNCTION cp_sll_char_get_el_at 00574 00575 ! ***************************************************************************** 00589 SUBROUTINE cp_sll_char_set_el_at(sll,index,value,error) 00590 TYPE(cp_sll_char_type), POINTER :: sll 00591 INTEGER, INTENT(in) :: index 00592 CHARACTER(len=default_string_length), 00593 INTENT(in) :: value 00594 TYPE(cp_error_type), INTENT(inout) :: error 00595 00596 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_set_el_at', 00597 routineP = moduleN//':'//routineN 00598 00599 LOGICAL :: failure 00600 TYPE(cp_sll_char_type), POINTER :: pos 00601 00602 failure=.FALSE. 00603 00604 IF (index==-1) THEN 00605 pos => cp_sll_char_get_rest(sll, iter=-1,error=error) 00606 ELSE 00607 pos => cp_sll_char_get_rest(sll, iter=index-1,error=error) 00608 END IF 00609 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00610 IF (.NOT.failure) THEN 00611 pos%first_el = value 00612 END IF 00613 END SUBROUTINE cp_sll_char_set_el_at 00614 00615 ! * iteration * 00616 00617 ! ***************************************************************************** 00628 FUNCTION cp_sll_char_next(iterator,el_att,error) RESULT(res) 00629 TYPE(cp_sll_char_type), POINTER :: iterator 00630 CHARACTER(len=default_string_length), 00631 INTENT(out), OPTIONAL :: el_att 00632 TYPE(cp_error_type), INTENT(inout) :: error 00633 LOGICAL :: res 00634 00635 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_next', 00636 routineP = moduleN//':'//routineN 00637 00638 LOGICAL :: failure 00639 00640 failure=.FALSE. 00641 00642 IF (ASSOCIATED(iterator)) THEN 00643 res=.NOT.failure 00644 IF (PRESENT(el_att)) el_att = iterator%first_el 00645 iterator => iterator%rest 00646 ELSE 00647 res=.FALSE. 00648 END IF 00649 END FUNCTION cp_sll_char_next 00650 00651 ! ============ structure modifications ============ 00652 00653 ! ***************************************************************************** 00666 SUBROUTINE cp_sll_char_insert_el(sll,el,error) 00667 TYPE(cp_sll_char_type), POINTER :: sll 00668 CHARACTER(len=default_string_length), 00669 INTENT(in) :: el 00670 TYPE(cp_error_type), INTENT(inout) :: error 00671 00672 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_el', 00673 routineP = moduleN//':'//routineN 00674 00675 LOGICAL :: failure 00676 TYPE(cp_sll_char_type), POINTER :: newSlot 00677 00678 failure=.FALSE. 00679 NULLIFY(newSlot) 00680 00681 CALL cp_sll_char_create(newSlot,first_el=el,& 00682 rest=sll,error=error) 00683 sll => newSlot 00684 END SUBROUTINE cp_sll_char_insert_el 00685 00686 ! ***************************************************************************** 00697 SUBROUTINE cp_sll_char_rm_first_el(sll,error) 00698 TYPE(cp_sll_char_type), POINTER :: sll 00699 TYPE(cp_error_type), INTENT(inout) :: error 00700 00701 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_rm_first_el', 00702 routineP = moduleN//':'//routineN 00703 00704 LOGICAL :: failure 00705 TYPE(cp_sll_char_type), POINTER :: node_to_rm 00706 00707 failure=.FALSE. 00708 node_to_rm => sll 00709 00710 IF (ASSOCIATED(sll)) THEN 00711 sll => sll%rest 00712 CALL cp_sll_char_dealloc_node(node_to_rm,error=error) 00713 ELSE 00714 CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& 00715 routineP,"tried to remove first el of an empty list in "//& 00716 CPSourceFileRef,& 00717 error,failure) 00718 END IF 00719 END SUBROUTINE cp_sll_char_rm_first_el 00720 00721 ! ***************************************************************************** 00735 SUBROUTINE cp_sll_char_insert_el_at(sll,el,index,error) 00736 TYPE(cp_sll_char_type), POINTER :: sll 00737 CHARACTER(len=default_string_length), 00738 INTENT(in) :: el 00739 INTEGER, INTENT(in) :: index 00740 TYPE(cp_error_type), INTENT(inout) :: error 00741 00742 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_el_at', 00743 routineP = moduleN//':'//routineN 00744 00745 LOGICAL :: failure 00746 TYPE(cp_sll_char_type), POINTER :: pos 00747 00748 failure=.FALSE. 00749 00750 IF (index==1) THEN 00751 CALL cp_sll_char_insert_el(sll,el,error=error) 00752 ELSE 00753 IF (index==-1) THEN 00754 pos => cp_sll_char_get_rest(sll, iter=-1,error=error) 00755 ELSE 00756 pos => cp_sll_char_get_rest(sll, iter=index-2,error=error) 00757 END IF 00758 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00759 IF (.NOT.failure) THEN 00760 CALL cp_sll_char_insert_el(pos%rest,el,error=error) 00761 END IF 00762 END IF 00763 END SUBROUTINE cp_sll_char_insert_el_at 00764 00765 ! ***************************************************************************** 00778 SUBROUTINE cp_sll_char_rm_el_at(sll,index,error) 00779 TYPE(cp_sll_char_type), POINTER :: sll 00780 INTEGER, INTENT(in) :: index 00781 TYPE(cp_error_type), INTENT(inout) :: error 00782 00783 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_rm_el_at', 00784 routineP = moduleN//':'//routineN 00785 00786 LOGICAL :: failure 00787 TYPE(cp_sll_char_type), POINTER :: pos 00788 00789 failure=.FALSE. 00790 00791 IF (cp_debug) THEN 00792 CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) 00793 END IF 00794 IF (index==1) THEN 00795 CALL cp_sll_char_rm_first_el(sll,error=error) 00796 ELSE 00797 IF (index==-1) THEN 00798 pos => cp_sll_char_get_rest(sll, iter=-1,error=error) 00799 ELSE 00800 pos => cp_sll_char_get_rest(sll, iter=index-2,error=error) 00801 END IF 00802 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00803 IF (.NOT.failure) THEN 00804 CALL cp_sll_char_rm_first_el(pos%rest,error=error) 00805 END IF 00806 END IF 00807 END SUBROUTINE cp_sll_char_rm_el_at 00808 00809 ! ***************************************************************************** 00820 SUBROUTINE cp_sll_char_rm_all_el(sll,error) 00821 TYPE(cp_sll_char_type), POINTER :: sll 00822 TYPE(cp_error_type), INTENT(inout) :: error 00823 00824 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_rm_all_el', 00825 routineP = moduleN//':'//routineN 00826 00827 LOGICAL :: failure 00828 TYPE(cp_sll_char_type), POINTER :: actual_node, next_node 00829 00830 failure=.FALSE. 00831 00832 actual_node => sll 00833 DO 00834 IF (.NOT.ASSOCIATED(actual_node)) EXIT 00835 next_node => actual_node%rest 00836 CALL cp_sll_char_dealloc_node(actual_node,error=error) 00837 actual_node => next_node 00838 END DO 00839 NULLIFY(sll) 00840 END SUBROUTINE cp_sll_char_rm_all_el 00841 00842 ! ***************************************************************************** 00852 FUNCTION cp_sll_char_to_array(sll,error) RESULT(res) 00853 TYPE(cp_sll_char_type), POINTER :: sll 00854 TYPE(cp_error_type), INTENT(inout) :: error 00855 CHARACTER(len=default_string_length), 00856 DIMENSION(:), POINTER :: res 00857 00858 INTEGER :: i, len, stat 00859 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_to_array', 00860 routineP = moduleN//':'//routineN 00861 00862 LOGICAL :: failure 00863 TYPE(cp_sll_char_type), POINTER :: iter 00864 00865 failure=.FALSE. 00866 00867 len=cp_sll_char_get_length(sll,error) 00868 ALLOCATE(res(len),stat=stat) 00869 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00870 IF (.NOT. failure) THEN 00871 iter => sll 00872 DO i=1,len 00873 res(i) = iter%first_el 00874 IF (.NOT.(cp_sll_char_next(iter,error=error).OR.i==len)) THEN 00875 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00876 END IF 00877 END DO 00878 END IF 00879 END FUNCTION cp_sll_char_to_array 00880 00881 ! ***************************************************************************** 00890 FUNCTION cp_sll_char_from_array(array,error) RESULT(res) 00891 CHARACTER(len=default_string_length), 00892 DIMENSION(:), INTENT(in) :: array 00893 TYPE(cp_error_type), INTENT(inout) :: error 00894 TYPE(cp_sll_char_type), POINTER :: res 00895 00896 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_from_array', 00897 routineP = moduleN//':'//routineN 00898 00899 INTEGER :: i 00900 LOGICAL :: failure 00901 TYPE(cp_sll_char_type), POINTER :: last_el 00902 00903 failure=.FALSE. 00904 00905 NULLIFY(res,last_el) 00906 IF (SIZE(array)>0) THEN 00907 CALL cp_sll_char_create(res,& 00908 first_el=array(1),& 00909 error=error) 00910 last_el => res 00911 END IF 00912 DO i=2,SIZE(array) 00913 CALL cp_sll_char_create(last_el%rest,& 00914 first_el=array(i),& 00915 error=error) 00916 last_el => last_el%rest 00917 END DO 00918 END FUNCTION cp_sll_char_from_array 00919 00920 ! ***************************************************************************** 00935 SUBROUTINE cp_sll_char_insert_ordered(sll,el,insert_equals,& 00936 did_insert,pos,error) 00937 TYPE(cp_sll_char_type), POINTER :: sll 00938 CHARACTER(len=default_string_length), 00939 INTENT(in) :: el 00940 LOGICAL, INTENT(in), OPTIONAL :: insert_equals 00941 LOGICAL, INTENT(out), OPTIONAL :: did_insert 00942 TYPE(cp_sll_char_type), OPTIONAL, 00943 POINTER :: pos 00944 TYPE(cp_error_type), INTENT(inout) :: error 00945 00946 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_ordered', 00947 routineP = moduleN//':'//routineN 00948 00949 LOGICAL :: failure, i_eq 00950 TYPE(cp_sll_char_type), POINTER :: iter 00951 00952 failure=.FALSE. 00953 i_eq=.FALSE. 00954 00955 IF (PRESENT(did_insert)) did_insert=.FALSE. 00956 IF (PRESENT(pos)) NULLIFY(pos) 00957 00958 IF (PRESENT(insert_equals)) i_eq=insert_equals 00959 IF (.NOT.ASSOCIATED(sll)) THEN 00960 CALL cp_sll_char_create(sll,first_el=el,error=error) 00961 IF (PRESENT(did_insert)) did_insert=.TRUE. 00962 IF (PRESENT(pos)) pos=>sll 00963 ELSE IF (.NOT.CP_SLL_C_LESS_Q(sll%first_el,el,error=error)) THEN 00964 IF (PRESENT(pos)) pos=>sll 00965 IF (i_eq.OR.CP_SLL_C_LESS_Q(el,sll%first_el,error=error)) THEN 00966 CALL cp_sll_char_insert_el(sll,el,error=error) 00967 IF (PRESENT(did_insert)) did_insert=.TRUE. 00968 IF (PRESENT(pos)) pos=>sll 00969 END IF 00970 ELSE 00971 iter => sll 00972 DO 00973 IF (.NOT.ASSOCIATED(iter%rest)) THEN 00974 CALL cp_sll_char_insert_el(iter%rest,el,error=error) 00975 IF (PRESENT(did_insert)) did_insert=.TRUE. 00976 IF (PRESENT(pos)) pos=>iter%rest 00977 EXIT 00978 ELSE IF (.NOT.CP_SLL_C_LESS_Q(iter%rest%first_el,el,error=error)) THEN 00979 IF (PRESENT(pos)) pos=>iter 00980 IF (i_eq.OR. CP_SLL_C_LESS_Q(el,iter%rest%first_el,error=error)) THEN 00981 CALL cp_sll_char_insert_el(iter%rest,el,error=error) 00982 IF (PRESENT(did_insert)) did_insert=.TRUE. 00983 IF (PRESENT(pos)) pos=>iter%rest 00984 END IF 00985 EXIT 00986 END IF 00987 CPInvariant(cp_sll_char_next(iter,error=error),cp_failure_level,routineP,error,failure) 00988 END DO 00989 CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) 00990 END IF 00991 END SUBROUTINE cp_sll_char_insert_ordered 00992 00993 ! ***************************************************************************** 01008 SUBROUTINE cp_sll_char_insert_ordered2(sll,el,compare_function,& 01009 insert_equals,did_insert,pos,error) 01010 TYPE(cp_sll_char_type), POINTER :: sll 01011 CHARACTER(len=default_string_length), 01012 INTENT(in) :: el 01013 INTERFACE 01014 ! ***************************************************************************** 01015 FUNCTION compare_function(el1,el2) 01016 USE kinds, ONLY: default_string_length 01017 INTEGER :: compare_function 01018 CHARACTER(len=default_string_length), INTENT(in) :: el1,el2 01019 END FUNCTION compare_function 01020 END INTERFACE 01021 LOGICAL, INTENT(in), OPTIONAL :: insert_equals 01022 LOGICAL, INTENT(out), OPTIONAL :: did_insert 01023 TYPE(cp_sll_char_type), OPTIONAL, 01024 POINTER :: pos 01025 TYPE(cp_error_type), INTENT(inout) :: error 01026 01027 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_ordered2', 01028 routineP = moduleN//':'//routineN 01029 01030 INTEGER :: comp 01031 LOGICAL :: failure, i_eq 01032 TYPE(cp_sll_char_type), POINTER :: iter 01033 01034 failure=.FALSE. 01035 i_eq=.FALSE. 01036 01037 IF (PRESENT(did_insert)) did_insert=.FALSE. 01038 IF (PRESENT(pos)) NULLIFY(pos) 01039 01040 IF (PRESENT(insert_equals)) i_eq=insert_equals 01041 IF (.NOT.ASSOCIATED(sll)) THEN 01042 CALL cp_sll_char_create(sll,first_el=el,error=error) 01043 IF (PRESENT(did_insert)) did_insert=.TRUE. 01044 IF (PRESENT(pos)) pos=>sll%rest 01045 RETURN 01046 END IF 01047 comp=compare_function(sll%first_el,el) 01048 IF (comp>=0) THEN 01049 IF (i_eq.OR.comp/=0) THEN 01050 CALL cp_sll_char_insert_el(sll,el,error=error) 01051 IF (PRESENT(did_insert)) did_insert=.TRUE. 01052 IF (PRESENT(pos)) pos=>sll%rest 01053 END IF 01054 ELSE 01055 iter => sll 01056 DO 01057 IF (.NOT.ASSOCIATED(iter%rest)) THEN 01058 CALL cp_sll_char_insert_el(iter%rest,el,error=error) 01059 IF (PRESENT(did_insert)) did_insert=.TRUE. 01060 IF (PRESENT(pos)) pos=>iter%rest 01061 EXIT 01062 END IF 01063 comp=compare_function(iter%rest%first_el,el) 01064 IF (comp>=0) THEN 01065 IF (i_eq.OR. comp/=0) THEN 01066 CALL cp_sll_char_insert_el(iter%rest,el,error=error) 01067 IF (PRESENT(did_insert)) did_insert=.TRUE. 01068 IF (PRESENT(pos)) pos=>iter%rest 01069 END IF 01070 EXIT 01071 END IF 01072 CPInvariant(cp_sll_char_next(iter,error=error),cp_failure_level,routineP,error,failure) 01073 END DO 01074 CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) 01075 END IF 01076 END SUBROUTINE cp_sll_char_insert_ordered2 01077 01078 ! ***************************************************************************** 01092 FUNCTION cp_sll_char_contains(sll,el,ordered,error) RESULT(res) 01093 TYPE(cp_sll_char_type), POINTER :: sll 01094 CHARACTER(len=default_string_length), 01095 INTENT(in) :: el 01096 LOGICAL, INTENT(in), OPTIONAL :: ordered 01097 TYPE(cp_error_type), INTENT(inout) :: error 01098 LOGICAL :: res 01099 01100 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_contains', 01101 routineP = moduleN//':'//routineN 01102 01103 CHARACTER(len=default_string_length) :: el_att 01104 LOGICAL :: failure, ord 01105 TYPE(cp_sll_char_type), POINTER :: iter 01106 01107 failure=.FALSE.; ord=.FALSE. 01108 res=.FALSE. 01109 01110 iter => sll 01111 IF (PRESENT(ordered)) ord=ordered 01112 IF (ord) THEN 01113 DO 01114 IF (.NOT.cp_sll_char_next(iter,el_att=el_att,error=error)) EXIT 01115 IF (.NOT.CP_SLL_C_LESS_Q(el_att,el,error=error)) THEN 01116 res=.NOT.CP_SLL_C_LESS_Q(el,el_att,error=error) 01117 RETURN 01118 END IF 01119 END DO 01120 ELSE 01121 DO 01122 IF (.NOT.cp_sll_char_next(iter,el_att=el_att,error=error)) EXIT 01123 IF (.NOT.CP_SLL_C_EQUAL_Q(el_att,el,error)) THEN 01124 res=.TRUE. 01125 RETURN 01126 END IF 01127 END DO 01128 END IF 01129 END FUNCTION cp_sll_char_contains 01130 01131 ! ***************************************************************************** 01148 FUNCTION cp_sll_char_contains2(sll,el,compare_function,ordered,error)& 01149 RESULT(res) 01150 TYPE(cp_sll_char_type), POINTER :: sll 01151 CHARACTER(len=default_string_length), 01152 INTENT(in) :: el 01153 INTERFACE 01154 ! ***************************************************************************** 01155 FUNCTION compare_function(el1,el2) 01156 USE kinds, ONLY: default_string_length 01157 INTEGER :: compare_function 01158 CHARACTER(len=default_string_length), INTENT(in) :: el1,el2 01159 END FUNCTION compare_function 01160 END INTERFACE 01161 LOGICAL, INTENT(in), OPTIONAL :: ordered 01162 TYPE(cp_error_type), INTENT(inout) :: error 01163 LOGICAL :: res 01164 01165 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_contains2', 01166 routineP = moduleN//':'//routineN 01167 01168 CHARACTER(len=default_string_length) :: el_att 01169 INTEGER :: comp 01170 LOGICAL :: failure 01171 TYPE(cp_sll_char_type), POINTER :: iter 01172 01173 failure=.FALSE. 01174 res=.FALSE. 01175 01176 iter => sll 01177 IF (ordered) THEN 01178 DO 01179 IF (.NOT.cp_sll_char_next(iter,el_att=el_att,error=error)) EXIT 01180 comp=compare_function(el_att,el) 01181 IF (comp>=0) THEN 01182 res= comp==0 01183 RETURN 01184 END IF 01185 END DO 01186 ELSE 01187 DO 01188 IF (.NOT.cp_sll_char_next(iter,el_att=el_att,error=error)) EXIT 01189 IF (compare_function(el_att,el)==0) THEN 01190 res=.TRUE. 01191 RETURN 01192 END IF 01193 END DO 01194 END IF 01195 END FUNCTION cp_sll_char_contains2 01196 01197 ! template def put here so that line numbers in template and derived 01198 ! files are almost the same (multi-line use change it a bit) 01199 ! [template(defines,nametype1,type1,type1in,type1out,type1arrayEl,arrayEl,array=,=,USE,write_el,lessQ,equalQ,private_routines)] 01200 ! ARGS: 01201 ! = = "=" 01202 ! USE = "USE kinds, only: default_string_length" 01203 ! array= = "=" 01204 ! arrayEl = "" 01205 ! defines = 01206 ! "#define CP_SLL_C_LESS_Q(el1,el2,error) ( el1 < el2 ) 01207 ! #define CP_SLL_C_EQUAL_Q(el1,el2,error) ( el1 == el2 ) 01208 ! " 01209 ! equalQ = "CP_SLL_C_EQUAL_Q" 01210 ! lessQ = "CP_SLL_C_LESS_Q" 01211 ! nametype1 = "char" 01212 ! private_routines = 01213 ! "subroutine write_string(str,unit_nr,error) 01214 ! character(len=*),intent(in) :: str 01215 ! integer, intent(in) :: unit_nr 01216 ! type(cp_error_type), intent(inout) :: error 01217 ! 01218 ! write(unit_nr,"(a,a,a)") '"',trim(str),'"' 01219 ! end subroutine write_string 01220 ! " 01221 ! type1 = "character(len=default_string_length)" 01222 ! type1arrayEl = "character(len=default_string_length)" 01223 ! type1in = "character(len=default_string_length), intent(in)" 01224 ! type1out = "character(len=default_string_length), intent(out)" 01225 ! write_el = "" 01226 01227 01228 END MODULE cp_linked_list_char 01229
1.7.3