|
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 ! less not much meningful... 00007 #define CP_SLL_FM_LESS_Q(el1,el2,error) ( el1 %id_nr < el2 %id_nr ) 00008 #define CP_SLL_FM_EQUAL_Q(el1,el2,error) ( el1 %id_nr == el2 %id_nr ) 00009 00010 00011 ! ***************************************************************************** 00047 MODULE cp_linked_list_fm 00048 USE cp_fm_types, ONLY: cp_fm_p_type,& 00049 cp_fm_type 00050 USE f77_blas 00051 USE kinds, ONLY: dp 00052 #include "cp_common_uses.h" 00053 00054 IMPLICIT NONE 00055 PRIVATE 00056 00057 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. 00058 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_linked_list_fm' 00059 00060 ! type 00061 PUBLIC :: cp_sll_fm_type, cp_sll_fm_p_type 00062 ! common methods 00063 PUBLIC :: cp_create, cp_dealloc, cp_get, cp_set, cp_next 00064 ! special get 00065 PUBLIC :: cp_get_first_el, cp_get_rest, cp_get_empty, cp_get_length,& 00066 cp_get_element_at, cp_to_array 00067 ! special set 00068 PUBLIC :: cp_set_element_at 00069 ! structure manipulation 00070 PUBLIC :: cp_insert, cp_remove_first_el, cp_remove_el, cp_remove_all 00071 ! low level 00072 PUBLIC :: cp_dealloc_node 00073 00074 ! underlying routines 00075 PUBLIC :: cp_sll_fm_create, cp_sll_fm_dealloc,& 00076 cp_sll_fm_dealloc_node,cp_sll_fm_set,& 00077 cp_sll_fm_get,cp_sll_fm_next,& 00078 cp_sll_fm_get_first_el, cp_sll_fm_get_rest,& 00079 cp_sll_fm_get_empty, cp_sll_fm_get_length,& 00080 cp_sll_fm_get_el_at, cp_sll_fm_set_el_at,& 00081 cp_sll_fm_insert_el, cp_sll_fm_insert_el_at,& 00082 cp_sll_fm_rm_first_el, cp_sll_fm_rm_el_at,& 00083 cp_sll_fm_rm_all_el, & 00084 cp_sll_fm_to_array,& 00085 cp_sll_fm_from_array, cp_sll_fm_insert_ordered,& 00086 cp_sll_fm_insert_ordered2 00087 00088 ! creation of an object (from a pointer) 00089 INTERFACE cp_create 00090 MODULE PROCEDURE cp_sll_fm_create 00091 END INTERFACE 00092 ! destruction of an object (from a pointer) 00093 INTERFACE cp_dealloc 00094 MODULE PROCEDURE cp_sll_fm_dealloc 00095 END INTERFACE 00096 ! destruction only of the node (low level) 00097 INTERFACE cp_dealloc_node 00098 MODULE PROCEDURE cp_sll_fm_dealloc_node 00099 END INTERFACE 00100 ! modifies attributes of an object 00101 INTERFACE cp_set 00102 MODULE PROCEDURE cp_sll_fm_set 00103 END INTERFACE 00104 ! returns attributes of an object 00105 INTERFACE cp_get 00106 MODULE PROCEDURE cp_sll_fm_get 00107 END INTERFACE 00108 ! iterates to the next element 00109 INTERFACE cp_next 00110 MODULE PROCEDURE cp_sll_fm_next 00111 END INTERFACE 00112 ! returns the first element 00113 INTERFACE cp_get_first_el 00114 MODULE PROCEDURE cp_sll_fm_get_first_el 00115 END INTERFACE 00116 ! returns the rest of the list 00117 INTERFACE cp_get_rest 00118 MODULE PROCEDURE cp_sll_fm_get_rest 00119 END INTERFACE 00120 ! returns if the list is empty 00121 INTERFACE cp_get_empty 00122 MODULE PROCEDURE cp_sll_fm_get_empty 00123 END INTERFACE 00124 ! returns the length of the list 00125 INTERFACE cp_get_length 00126 MODULE PROCEDURE cp_sll_fm_get_length 00127 END INTERFACE 00128 ! returns the element at the given position 00129 INTERFACE cp_get_element_at 00130 MODULE PROCEDURE cp_sll_fm_get_el_at 00131 END INTERFACE 00132 ! sets the element at the given position 00133 INTERFACE cp_set_element_at 00134 MODULE PROCEDURE cp_sll_fm_set_el_at 00135 END INTERFACE 00136 ! inserts one element call cp_insert(list,element,...) 00137 INTERFACE cp_insert 00138 MODULE PROCEDURE cp_sll_fm_insert_el 00139 END INTERFACE 00140 !MK INTERFACE cp_insert_ordered 00141 !MK MODULE PROCEDURE cp_sll_fm_insert_ordered,& 00142 !MK cp_sll_fm_insert_ordered2 00143 !MK END INTERFACE 00144 INTERFACE cp_insert_at 00145 MODULE PROCEDURE cp_sll_fm_insert_el_at 00146 END INTERFACE 00147 ! removes an element 00148 INTERFACE cp_remove_el 00149 MODULE PROCEDURE cp_sll_fm_rm_first_el, & 00150 cp_sll_fm_rm_el_at 00151 END INTERFACE 00152 ! removes the first el 00153 INTERFACE cp_remove_first_el 00154 MODULE PROCEDURE cp_sll_fm_rm_first_el 00155 END INTERFACE 00156 ! remove all the elments 00157 INTERFACE cp_remove_all 00158 MODULE PROCEDURE cp_sll_fm_rm_all_el 00159 END INTERFACE 00160 ! transorms the list in array 00161 INTERFACE cp_to_array 00162 MODULE PROCEDURE cp_sll_fm_to_array 00163 END INTERFACE 00164 00165 ! ***************************************************************************** 00187 TYPE cp_sll_fm_type 00188 TYPE(cp_fm_type),POINTER :: first_el 00189 TYPE(cp_sll_fm_type), POINTER :: rest 00190 END TYPE cp_sll_fm_type 00191 00192 ! ***************************************************************************** 00199 TYPE cp_sll_fm_p_type 00200 TYPE(cp_sll_fm_type), POINTER :: list 00201 END TYPE cp_sll_fm_p_type 00202 00203 CONTAINS 00204 00205 00206 ! =========== creation / distruction ======== 00207 00208 ! ***************************************************************************** 00219 SUBROUTINE cp_sll_fm_create(sll,first_el,rest,error) 00220 TYPE(cp_sll_fm_type), POINTER :: sll 00221 TYPE(cp_fm_type), OPTIONAL, POINTER :: first_el 00222 TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: rest 00223 TYPE(cp_error_type), INTENT(inout) :: error 00224 00225 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_create', 00226 routineP = moduleN//':'//routineN 00227 00228 INTEGER :: stat 00229 LOGICAL :: failure 00230 00231 failure=.FALSE. 00232 00233 IF (.NOT.PRESENT(first_el)) THEN 00234 NULLIFY(sll) 00235 IF (PRESENT(rest)) sll => rest 00236 ELSE 00237 ALLOCATE(sll, stat=stat) 00238 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00239 IF (.NOT.failure) THEN 00240 sll%first_el => first_el 00241 NULLIFY(sll%rest) 00242 IF (PRESENT(rest)) sll%rest => rest 00243 END IF 00244 END IF 00245 IF (failure) NULLIFY(sll) 00246 END SUBROUTINE cp_sll_fm_create 00247 00248 ! ***************************************************************************** 00261 SUBROUTINE cp_sll_fm_dealloc(sll,error) 00262 TYPE(cp_sll_fm_type), POINTER :: sll 00263 TYPE(cp_error_type), INTENT(inout) :: error 00264 00265 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_dealloc', 00266 routineP = moduleN//':'//routineN 00267 00268 CALL cp_sll_fm_rm_all_el(sll,error) 00269 END SUBROUTINE cp_sll_fm_dealloc 00270 00271 ! * low-level * 00272 00273 ! ***************************************************************************** 00282 SUBROUTINE cp_sll_fm_dealloc_node(sll,error) 00283 TYPE(cp_sll_fm_type), POINTER :: sll 00284 TYPE(cp_error_type), INTENT(inout) :: error 00285 00286 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_dealloc_node', 00287 routineP = moduleN//':'//routineN 00288 00289 INTEGER :: stat 00290 LOGICAL :: failure 00291 00292 failure=.FALSE. 00293 00294 DEALLOCATE(sll, stat=stat) 00295 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00296 END SUBROUTINE cp_sll_fm_dealloc_node 00297 00298 ! ============= get/set ============ 00299 00300 ! ***************************************************************************** 00313 SUBROUTINE cp_sll_fm_set(sll,first_el,rest,error) 00314 TYPE(cp_sll_fm_type), POINTER :: sll 00315 TYPE(cp_fm_type), OPTIONAL, POINTER :: first_el 00316 TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: rest 00317 TYPE(cp_error_type), INTENT(inout) :: error 00318 00319 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_set', 00320 routineP = moduleN//':'//routineN 00321 00322 LOGICAL :: failure 00323 00324 failure=.FALSE. 00325 00326 IF (.NOT.ASSOCIATED(sll)) THEN 00327 IF (PRESENT(first_el)) THEN 00328 CALL cp_sll_fm_create(sll,first_el,rest,error) 00329 ELSE 00330 CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) 00331 END IF 00332 ELSE 00333 IF (PRESENT(first_el)) sll%first_el => first_el 00334 IF (PRESENT(rest)) sll%rest => rest 00335 END IF 00336 END SUBROUTINE cp_sll_fm_set 00337 00338 ! ***************************************************************************** 00350 SUBROUTINE cp_sll_fm_get(sll,first_el,rest,empty,length,error) 00351 TYPE(cp_sll_fm_type), POINTER :: sll 00352 TYPE(cp_fm_type), OPTIONAL, POINTER :: first_el 00353 TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: rest 00354 LOGICAL, INTENT(out), OPTIONAL :: empty 00355 INTEGER, INTENT(out), OPTIONAL :: length 00356 TYPE(cp_error_type), INTENT(inout) :: error 00357 00358 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get', 00359 routineP = moduleN//':'//routineN 00360 00361 LOGICAL :: failure 00362 00363 failure=.FALSE. 00364 00365 IF (.NOT.ASSOCIATED(sll)) THEN 00366 CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) 00367 IF (PRESENT(rest)) NULLIFY(rest) 00368 IF (PRESENT(empty)) empty=.TRUE. 00369 IF (PRESENT(length)) length=0 00370 ELSE 00371 IF (PRESENT(first_el)) first_el => sll%first_el 00372 IF (PRESENT(rest)) rest => sll%rest 00373 IF (PRESENT(empty)) empty = .FALSE. 00374 IF (PRESENT(length)) & 00375 length = cp_sll_fm_get_length(sll,error=error) 00376 END IF 00377 END SUBROUTINE cp_sll_fm_get 00378 00379 ! ***************************************************************************** 00388 FUNCTION cp_sll_fm_get_first_el(sll,error) RESULT(res) 00389 TYPE(cp_sll_fm_type), POINTER :: sll 00390 TYPE(cp_error_type), INTENT(inout) :: error 00391 TYPE(cp_fm_type), POINTER :: res 00392 00393 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_first_el', 00394 routineP = moduleN//':'//routineN 00395 00396 LOGICAL :: failure 00397 00398 failure=.FALSE. 00399 00400 IF (cp_debug) THEN 00401 CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) 00402 END IF 00403 IF (.NOT. failure) THEN 00404 res => sll%first_el 00405 END IF 00406 END FUNCTION cp_sll_fm_get_first_el 00407 00408 ! ***************************************************************************** 00421 FUNCTION cp_sll_fm_get_rest(sll, iter, error) RESULT(res) 00422 TYPE(cp_sll_fm_type), POINTER :: sll 00423 INTEGER, OPTIONAL :: iter 00424 TYPE(cp_error_type), INTENT(inout) :: error 00425 TYPE(cp_sll_fm_type), POINTER :: res 00426 00427 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_rest', 00428 routineP = moduleN//':'//routineN 00429 00430 INTEGER :: i 00431 LOGICAL :: failure 00432 00433 failure=.FALSE. 00434 00435 IF (.NOT.ASSOCIATED(sll)) THEN 00436 NULLIFY(res) 00437 ELSE 00438 IF (.NOT. failure) THEN 00439 IF (PRESENT(iter)) THEN 00440 res => sll 00441 DO i=1,iter 00442 IF (ASSOCIATED(res%rest)) THEN 00443 res => res%rest 00444 ELSE 00445 CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& 00446 routineP, "tried to go past end in "// & 00447 CPSourceFileRef,& 00448 error,failure) 00449 END IF 00450 END DO 00451 IF (iter==-1) THEN 00452 DO 00453 IF (.NOT.ASSOCIATED(res%rest)) EXIT 00454 res => res%rest 00455 END DO 00456 END IF 00457 ELSE 00458 res => sll%rest ! make the common case fast... 00459 END IF 00460 ELSE 00461 NULLIFY(res) 00462 END IF 00463 END IF 00464 END FUNCTION cp_sll_fm_get_rest 00465 00466 ! ***************************************************************************** 00474 FUNCTION cp_sll_fm_get_empty(sll,error) RESULT(res) 00475 TYPE(cp_sll_fm_type), POINTER :: sll 00476 TYPE(cp_error_type), INTENT(inout) :: error 00477 LOGICAL :: res 00478 00479 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_empty', 00480 routineP = moduleN//':'//routineN 00481 00482 LOGICAL :: failure 00483 00484 failure=.FALSE. 00485 00486 res = .NOT.ASSOCIATED(sll) 00487 END FUNCTION cp_sll_fm_get_empty 00488 00489 ! ***************************************************************************** 00500 FUNCTION cp_sll_fm_get_length(sll,error) RESULT(res) 00501 TYPE(cp_sll_fm_type), POINTER :: sll 00502 TYPE(cp_error_type), INTENT(inout) :: error 00503 INTEGER :: res 00504 00505 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_length', 00506 routineP = moduleN//':'//routineN 00507 00508 LOGICAL :: failure 00509 TYPE(cp_sll_fm_type), POINTER :: iterator 00510 00511 failure=.FALSE. 00512 00513 res=0 00514 iterator => sll 00515 DO 00516 IF (ASSOCIATED(iterator)) THEN 00517 res=res+1 00518 iterator => iterator%rest 00519 ELSE 00520 EXIT 00521 END IF 00522 END DO 00523 END FUNCTION cp_sll_fm_get_length 00524 00525 ! ***************************************************************************** 00537 FUNCTION cp_sll_fm_get_el_at(sll,index,error) RESULT(res) 00538 TYPE(cp_sll_fm_type), POINTER :: sll 00539 INTEGER, INTENT(in) :: index 00540 TYPE(cp_error_type), INTENT(inout) :: error 00541 TYPE(cp_fm_type), POINTER :: res 00542 00543 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_el_at', 00544 routineP = moduleN//':'//routineN 00545 00546 LOGICAL :: failure 00547 TYPE(cp_sll_fm_type), POINTER :: pos 00548 00549 failure=.FALSE. 00550 00551 IF (cp_debug) THEN 00552 CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) 00553 END IF 00554 IF (index==-1) THEN 00555 pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) 00556 ELSE 00557 pos => cp_sll_fm_get_rest(sll, iter=index-1,error=error) 00558 END IF 00559 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00560 IF (.NOT.failure) THEN 00561 res => pos%first_el 00562 END IF 00563 END FUNCTION cp_sll_fm_get_el_at 00564 00565 ! ***************************************************************************** 00579 SUBROUTINE cp_sll_fm_set_el_at(sll,index,value,error) 00580 TYPE(cp_sll_fm_type), POINTER :: sll 00581 INTEGER, INTENT(in) :: index 00582 TYPE(cp_fm_type), POINTER :: value 00583 TYPE(cp_error_type), INTENT(inout) :: error 00584 00585 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_set_el_at', 00586 routineP = moduleN//':'//routineN 00587 00588 LOGICAL :: failure 00589 TYPE(cp_sll_fm_type), POINTER :: pos 00590 00591 failure=.FALSE. 00592 00593 IF (index==-1) THEN 00594 pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) 00595 ELSE 00596 pos => cp_sll_fm_get_rest(sll, iter=index-1,error=error) 00597 END IF 00598 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00599 IF (.NOT.failure) THEN 00600 pos%first_el => value 00601 END IF 00602 END SUBROUTINE cp_sll_fm_set_el_at 00603 00604 ! * iteration * 00605 00606 ! ***************************************************************************** 00617 FUNCTION cp_sll_fm_next(iterator,el_att,error) RESULT(res) 00618 TYPE(cp_sll_fm_type), POINTER :: iterator 00619 TYPE(cp_fm_type), OPTIONAL, POINTER :: el_att 00620 TYPE(cp_error_type), INTENT(inout) :: error 00621 LOGICAL :: res 00622 00623 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_next', 00624 routineP = moduleN//':'//routineN 00625 00626 LOGICAL :: failure 00627 00628 failure=.FALSE. 00629 00630 IF (ASSOCIATED(iterator)) THEN 00631 res=.NOT.failure 00632 IF (PRESENT(el_att)) el_att => iterator%first_el 00633 iterator => iterator%rest 00634 ELSE 00635 res=.FALSE. 00636 END IF 00637 END FUNCTION cp_sll_fm_next 00638 00639 ! ============ structure modifications ============ 00640 00641 ! ***************************************************************************** 00654 SUBROUTINE cp_sll_fm_insert_el(sll,el,error) 00655 TYPE(cp_sll_fm_type), POINTER :: sll 00656 TYPE(cp_fm_type), POINTER :: el 00657 TYPE(cp_error_type), INTENT(inout) :: error 00658 00659 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_el', 00660 routineP = moduleN//':'//routineN 00661 00662 LOGICAL :: failure 00663 TYPE(cp_sll_fm_type), POINTER :: newSlot 00664 00665 failure=.FALSE. 00666 NULLIFY(newSlot) 00667 00668 CALL cp_sll_fm_create(newSlot,first_el=el,& 00669 rest=sll,error=error) 00670 sll => newSlot 00671 END SUBROUTINE cp_sll_fm_insert_el 00672 00673 ! ***************************************************************************** 00684 SUBROUTINE cp_sll_fm_rm_first_el(sll,error) 00685 TYPE(cp_sll_fm_type), POINTER :: sll 00686 TYPE(cp_error_type), INTENT(inout) :: error 00687 00688 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_rm_first_el', 00689 routineP = moduleN//':'//routineN 00690 00691 LOGICAL :: failure 00692 TYPE(cp_sll_fm_type), POINTER :: node_to_rm 00693 00694 failure=.FALSE. 00695 node_to_rm => sll 00696 00697 IF (ASSOCIATED(sll)) THEN 00698 sll => sll%rest 00699 CALL cp_sll_fm_dealloc_node(node_to_rm,error=error) 00700 ELSE 00701 CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& 00702 routineP,"tried to remove first el of an empty list in "//& 00703 CPSourceFileRef,& 00704 error,failure) 00705 END IF 00706 END SUBROUTINE cp_sll_fm_rm_first_el 00707 00708 ! ***************************************************************************** 00722 SUBROUTINE cp_sll_fm_insert_el_at(sll,el,index,error) 00723 TYPE(cp_sll_fm_type), POINTER :: sll 00724 TYPE(cp_fm_type), POINTER :: el 00725 INTEGER, INTENT(in) :: index 00726 TYPE(cp_error_type), INTENT(inout) :: error 00727 00728 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_el_at', 00729 routineP = moduleN//':'//routineN 00730 00731 LOGICAL :: failure 00732 TYPE(cp_sll_fm_type), POINTER :: pos 00733 00734 failure=.FALSE. 00735 00736 IF (index==1) THEN 00737 CALL cp_sll_fm_insert_el(sll,el,error=error) 00738 ELSE 00739 IF (index==-1) THEN 00740 pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) 00741 ELSE 00742 pos => cp_sll_fm_get_rest(sll, iter=index-2,error=error) 00743 END IF 00744 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00745 IF (.NOT.failure) THEN 00746 CALL cp_sll_fm_insert_el(pos%rest,el,error=error) 00747 END IF 00748 END IF 00749 END SUBROUTINE cp_sll_fm_insert_el_at 00750 00751 ! ***************************************************************************** 00764 SUBROUTINE cp_sll_fm_rm_el_at(sll,index,error) 00765 TYPE(cp_sll_fm_type), POINTER :: sll 00766 INTEGER, INTENT(in) :: index 00767 TYPE(cp_error_type), INTENT(inout) :: error 00768 00769 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_rm_el_at', 00770 routineP = moduleN//':'//routineN 00771 00772 LOGICAL :: failure 00773 TYPE(cp_sll_fm_type), POINTER :: pos 00774 00775 failure=.FALSE. 00776 00777 IF (cp_debug) THEN 00778 CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) 00779 END IF 00780 IF (index==1) THEN 00781 CALL cp_sll_fm_rm_first_el(sll,error=error) 00782 ELSE 00783 IF (index==-1) THEN 00784 pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) 00785 ELSE 00786 pos => cp_sll_fm_get_rest(sll, iter=index-2,error=error) 00787 END IF 00788 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00789 IF (.NOT.failure) THEN 00790 CALL cp_sll_fm_rm_first_el(pos%rest,error=error) 00791 END IF 00792 END IF 00793 END SUBROUTINE cp_sll_fm_rm_el_at 00794 00795 ! ***************************************************************************** 00806 SUBROUTINE cp_sll_fm_rm_all_el(sll,error) 00807 TYPE(cp_sll_fm_type), POINTER :: sll 00808 TYPE(cp_error_type), INTENT(inout) :: error 00809 00810 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_rm_all_el', 00811 routineP = moduleN//':'//routineN 00812 00813 LOGICAL :: failure 00814 TYPE(cp_sll_fm_type), POINTER :: actual_node, next_node 00815 00816 failure=.FALSE. 00817 00818 actual_node => sll 00819 DO 00820 IF (.NOT.ASSOCIATED(actual_node)) EXIT 00821 next_node => actual_node%rest 00822 CALL cp_sll_fm_dealloc_node(actual_node,error=error) 00823 actual_node => next_node 00824 END DO 00825 NULLIFY(sll) 00826 END SUBROUTINE cp_sll_fm_rm_all_el 00827 00828 ! ***************************************************************************** 00838 FUNCTION cp_sll_fm_to_array(sll,error) RESULT(res) 00839 TYPE(cp_sll_fm_type), POINTER :: sll 00840 TYPE(cp_error_type), INTENT(inout) :: error 00841 TYPE(cp_fm_p_type), DIMENSION(:), 00842 POINTER :: res 00843 00844 INTEGER :: i, len, stat 00845 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_to_array', 00846 routineP = moduleN//':'//routineN 00847 00848 LOGICAL :: failure 00849 TYPE(cp_sll_fm_type), POINTER :: iter 00850 00851 failure=.FALSE. 00852 00853 len=cp_sll_fm_get_length(sll,error) 00854 ALLOCATE(res(len),stat=stat) 00855 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00856 IF (.NOT. failure) THEN 00857 iter => sll 00858 DO i=1,len 00859 res(i)%matrix => iter%first_el 00860 IF (.NOT.(cp_sll_fm_next(iter,error=error).OR.i==len)) THEN 00861 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00862 END IF 00863 END DO 00864 END IF 00865 END FUNCTION cp_sll_fm_to_array 00866 00867 ! ***************************************************************************** 00876 FUNCTION cp_sll_fm_from_array(array,error) RESULT(res) 00877 TYPE(cp_fm_p_type), DIMENSION(:), 00878 INTENT(in) :: array 00879 TYPE(cp_error_type), INTENT(inout) :: error 00880 TYPE(cp_sll_fm_type), POINTER :: res 00881 00882 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_from_array', 00883 routineP = moduleN//':'//routineN 00884 00885 INTEGER :: i 00886 LOGICAL :: failure 00887 TYPE(cp_sll_fm_type), POINTER :: last_el 00888 00889 failure=.FALSE. 00890 00891 NULLIFY(res,last_el) 00892 IF (SIZE(array)>0) THEN 00893 CALL cp_sll_fm_create(res,& 00894 first_el=array(1)%matrix,& 00895 error=error) 00896 last_el => res 00897 END IF 00898 DO i=2,SIZE(array) 00899 CALL cp_sll_fm_create(last_el%rest,& 00900 first_el=array(i)%matrix,& 00901 error=error) 00902 last_el => last_el%rest 00903 END DO 00904 END FUNCTION cp_sll_fm_from_array 00905 00906 ! ***************************************************************************** 00921 SUBROUTINE cp_sll_fm_insert_ordered(sll,el,insert_equals,& 00922 did_insert,pos,error) 00923 TYPE(cp_sll_fm_type), POINTER :: sll 00924 TYPE(cp_fm_type), POINTER :: el 00925 LOGICAL, INTENT(in), OPTIONAL :: insert_equals 00926 LOGICAL, INTENT(out), OPTIONAL :: did_insert 00927 TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: pos 00928 TYPE(cp_error_type), INTENT(inout) :: error 00929 00930 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_ordered', 00931 routineP = moduleN//':'//routineN 00932 00933 LOGICAL :: failure, i_eq 00934 TYPE(cp_sll_fm_type), POINTER :: iter 00935 00936 failure=.FALSE. 00937 i_eq=.FALSE. 00938 00939 IF (PRESENT(did_insert)) did_insert=.FALSE. 00940 IF (PRESENT(pos)) NULLIFY(pos) 00941 00942 IF (PRESENT(insert_equals)) i_eq=insert_equals 00943 IF (.NOT.ASSOCIATED(sll)) THEN 00944 CALL cp_sll_fm_create(sll,first_el=el,error=error) 00945 IF (PRESENT(did_insert)) did_insert=.TRUE. 00946 IF (PRESENT(pos)) pos=>sll 00947 ELSE IF (.NOT.CP_SLL_FM_LESS_Q(sll%first_el,el,error=error)) THEN 00948 IF (PRESENT(pos)) pos=>sll 00949 IF (i_eq.OR.CP_SLL_FM_LESS_Q(el,sll%first_el,error=error)) THEN 00950 CALL cp_sll_fm_insert_el(sll,el,error=error) 00951 IF (PRESENT(did_insert)) did_insert=.TRUE. 00952 IF (PRESENT(pos)) pos=>sll 00953 END IF 00954 ELSE 00955 iter => sll 00956 DO 00957 IF (.NOT.ASSOCIATED(iter%rest)) THEN 00958 CALL cp_sll_fm_insert_el(iter%rest,el,error=error) 00959 IF (PRESENT(did_insert)) did_insert=.TRUE. 00960 IF (PRESENT(pos)) pos=>iter%rest 00961 EXIT 00962 ELSE IF (.NOT.CP_SLL_FM_LESS_Q(iter%rest%first_el,el,error=error)) THEN 00963 IF (PRESENT(pos)) pos=>iter 00964 IF (i_eq.OR. CP_SLL_FM_LESS_Q(el,iter%rest%first_el,error=error)) THEN 00965 CALL cp_sll_fm_insert_el(iter%rest,el,error=error) 00966 IF (PRESENT(did_insert)) did_insert=.TRUE. 00967 IF (PRESENT(pos)) pos=>iter%rest 00968 END IF 00969 EXIT 00970 END IF 00971 CPInvariant(cp_sll_fm_next(iter,error=error),cp_failure_level,routineP,error,failure) 00972 END DO 00973 CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) 00974 END IF 00975 END SUBROUTINE cp_sll_fm_insert_ordered 00976 00977 ! ***************************************************************************** 00992 SUBROUTINE cp_sll_fm_insert_ordered2(sll,el,compare_function,& 00993 insert_equals,did_insert,pos,error) 00994 TYPE(cp_sll_fm_type), POINTER :: sll 00995 TYPE(cp_fm_type), POINTER :: el 00996 INTERFACE 00997 ! ***************************************************************************** 00998 FUNCTION compare_function(el1,el2) 00999 USE kinds, ONLY: dp 01000 USE cp_fm_types, ONLY: cp_fm_type, cp_fm_p_type 01001 INTEGER :: compare_function 01002 TYPE(cp_fm_type), POINTER :: el1,el2 01003 END FUNCTION compare_function 01004 END INTERFACE 01005 LOGICAL, INTENT(in), OPTIONAL :: insert_equals 01006 LOGICAL, INTENT(out), OPTIONAL :: did_insert 01007 TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: pos 01008 TYPE(cp_error_type), INTENT(inout) :: error 01009 01010 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_ordered2', 01011 routineP = moduleN//':'//routineN 01012 01013 INTEGER :: comp 01014 LOGICAL :: failure, i_eq 01015 TYPE(cp_sll_fm_type), POINTER :: iter 01016 01017 failure=.FALSE. 01018 i_eq=.FALSE. 01019 01020 IF (PRESENT(did_insert)) did_insert=.FALSE. 01021 IF (PRESENT(pos)) NULLIFY(pos) 01022 01023 IF (PRESENT(insert_equals)) i_eq=insert_equals 01024 IF (.NOT.ASSOCIATED(sll)) THEN 01025 CALL cp_sll_fm_create(sll,first_el=el,error=error) 01026 IF (PRESENT(did_insert)) did_insert=.TRUE. 01027 IF (PRESENT(pos)) pos=>sll%rest 01028 RETURN 01029 END IF 01030 comp=compare_function(sll%first_el,el) 01031 IF (comp>=0) THEN 01032 IF (i_eq.OR.comp/=0) THEN 01033 CALL cp_sll_fm_insert_el(sll,el,error=error) 01034 IF (PRESENT(did_insert)) did_insert=.TRUE. 01035 IF (PRESENT(pos)) pos=>sll%rest 01036 END IF 01037 ELSE 01038 iter => sll 01039 DO 01040 IF (.NOT.ASSOCIATED(iter%rest)) THEN 01041 CALL cp_sll_fm_insert_el(iter%rest,el,error=error) 01042 IF (PRESENT(did_insert)) did_insert=.TRUE. 01043 IF (PRESENT(pos)) pos=>iter%rest 01044 EXIT 01045 END IF 01046 comp=compare_function(iter%rest%first_el,el) 01047 IF (comp>=0) THEN 01048 IF (i_eq.OR. comp/=0) THEN 01049 CALL cp_sll_fm_insert_el(iter%rest,el,error=error) 01050 IF (PRESENT(did_insert)) did_insert=.TRUE. 01051 IF (PRESENT(pos)) pos=>iter%rest 01052 END IF 01053 EXIT 01054 END IF 01055 CPInvariant(cp_sll_fm_next(iter,error=error),cp_failure_level,routineP,error,failure) 01056 END DO 01057 CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) 01058 END IF 01059 END SUBROUTINE cp_sll_fm_insert_ordered2 01060 01061 ! ***************************************************************************** 01075 FUNCTION cp_sll_fm_contains(sll,el,ordered,error) RESULT(res) 01076 TYPE(cp_sll_fm_type), POINTER :: sll 01077 TYPE(cp_fm_type), POINTER :: el 01078 LOGICAL, INTENT(in), OPTIONAL :: ordered 01079 TYPE(cp_error_type), INTENT(inout) :: error 01080 LOGICAL :: res 01081 01082 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_contains', 01083 routineP = moduleN//':'//routineN 01084 01085 LOGICAL :: failure, ord 01086 TYPE(cp_fm_type), POINTER :: el_att 01087 TYPE(cp_sll_fm_type), POINTER :: iter 01088 01089 failure=.FALSE.; ord=.FALSE. 01090 res=.FALSE. 01091 01092 iter => sll 01093 IF (PRESENT(ordered)) ord=ordered 01094 IF (ord) THEN 01095 DO 01096 IF (.NOT.cp_sll_fm_next(iter,el_att=el_att,error=error)) EXIT 01097 IF (.NOT.CP_SLL_FM_LESS_Q(el_att,el,error=error)) THEN 01098 res=.NOT.CP_SLL_FM_LESS_Q(el,el_att,error=error) 01099 RETURN 01100 END IF 01101 END DO 01102 ELSE 01103 DO 01104 IF (.NOT.cp_sll_fm_next(iter,el_att=el_att,error=error)) EXIT 01105 IF (.NOT.CP_SLL_FM_EQUAL_Q(el_att,el,error)) THEN 01106 res=.TRUE. 01107 RETURN 01108 END IF 01109 END DO 01110 END IF 01111 END FUNCTION cp_sll_fm_contains 01112 01113 ! ***************************************************************************** 01130 FUNCTION cp_sll_fm_contains2(sll,el,compare_function,ordered,error)& 01131 RESULT(res) 01132 TYPE(cp_sll_fm_type), POINTER :: sll 01133 TYPE(cp_fm_type), POINTER :: el 01134 INTERFACE 01135 ! ***************************************************************************** 01136 FUNCTION compare_function(el1,el2) 01137 USE kinds, ONLY: dp 01138 USE cp_fm_types, ONLY: cp_fm_type, cp_fm_p_type 01139 INTEGER :: compare_function 01140 TYPE(cp_fm_type), POINTER :: el1,el2 01141 END FUNCTION compare_function 01142 END INTERFACE 01143 LOGICAL, INTENT(in), OPTIONAL :: ordered 01144 TYPE(cp_error_type), INTENT(inout) :: error 01145 LOGICAL :: res 01146 01147 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_contains2', 01148 routineP = moduleN//':'//routineN 01149 01150 INTEGER :: comp 01151 LOGICAL :: failure 01152 TYPE(cp_fm_type), POINTER :: el_att 01153 TYPE(cp_sll_fm_type), POINTER :: iter 01154 01155 failure=.FALSE. 01156 res=.FALSE. 01157 01158 iter => sll 01159 IF (ordered) THEN 01160 DO 01161 IF (.NOT.cp_sll_fm_next(iter,el_att=el_att,error=error)) EXIT 01162 comp=compare_function(el_att,el) 01163 IF (comp>=0) THEN 01164 res= comp==0 01165 RETURN 01166 END IF 01167 END DO 01168 ELSE 01169 DO 01170 IF (.NOT.cp_sll_fm_next(iter,el_att=el_att,error=error)) EXIT 01171 IF (compare_function(el_att,el)==0) THEN 01172 res=.TRUE. 01173 RETURN 01174 END IF 01175 END DO 01176 END IF 01177 END FUNCTION cp_sll_fm_contains2 01178 01179 ! template def put here so that line numbers in template and derived 01180 ! files are almost the same (multi-line use change it a bit) 01181 ! [template(defines,nametype1,type1,type1in,type1out,type1arrayEl,arrayEl,array=,=,USE,write_el,lessQ,equalQ,private_routines)] 01182 ! ARGS: 01183 ! = = "=>" 01184 ! USE = 01185 ! "USE kinds, only: dp 01186 ! USE cp_fm_types, ONLY: cp_fm_type, cp_fm_p_type" 01187 ! array= = "=>" 01188 ! arrayEl = "%matrix" 01189 ! defines = 01190 ! "! less not much meningful... 01191 ! #define CP_SLL_FM_LESS_Q(el1,el2,error) ( el1 %id_nr < el2 %id_nr ) 01192 ! #define CP_SLL_FM_EQUAL_Q(el1,el2,error) ( el1 %id_nr == el2 %id_nr ) 01193 ! " 01194 ! equalQ = "CP_SLL_FM_EQUAL_Q" 01195 ! lessQ = "CP_SLL_FM_LESS_Q" 01196 ! nametype1 = "fm" 01197 ! private_routines = "" 01198 ! type1 = "type(cp_fm_type),pointer" 01199 ! type1arrayEl = "type(cp_fm_p_type)" 01200 ! type1in = "type(cp_fm_type), pointer" 01201 ! type1out = "type(cp_fm_type), pointer" 01202 ! write_el = "" 01203 01204 01205 END MODULE cp_linked_list_fm 01206
1.7.3