|
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_DERIV_LESS_Q(el1,el2,error) cp_sll_deriv_less_q(el1,el2,error) 00007 #define CP_SLL_DERIV_EQUAL_Q(el1,el2,error) ( el1%desc == el2%desc ) 00008 00009 00010 ! ***************************************************************************** 00046 MODULE cp_linked_list_xc_deriv 00047 USE f77_blas 00048 USE kinds, ONLY: dp 00049 USE xc_derivative_types, ONLY: xc_derivative_p_type,& 00050 xc_derivative_type 00051 #include "cp_common_uses.h" 00052 00053 IMPLICIT NONE 00054 PRIVATE 00055 00056 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. 00057 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_linked_list_xc_deriv' 00058 00059 ! type 00060 PUBLIC :: cp_sll_xc_deriv_type, cp_sll_xc_deriv_p_type 00061 ! common methods 00062 PUBLIC :: cp_create, cp_dealloc, cp_get, cp_set, cp_next 00063 ! special get 00064 PUBLIC :: cp_get_first_el, cp_get_rest, cp_get_empty, cp_get_length,& 00065 cp_get_element_at, cp_to_array 00066 ! special set 00067 PUBLIC :: cp_set_element_at 00068 ! structure manipulation 00069 PUBLIC :: cp_insert, cp_remove_first_el, cp_remove_el, cp_remove_all 00070 ! low level 00071 PUBLIC :: cp_dealloc_node 00072 00073 ! underlying routines 00074 PUBLIC :: cp_sll_xc_deriv_create, cp_sll_xc_deriv_dealloc,& 00075 cp_sll_xc_deriv_dealloc_node,cp_sll_xc_deriv_set,& 00076 cp_sll_xc_deriv_get,cp_sll_xc_deriv_next,& 00077 cp_sll_xc_deriv_get_first_el, cp_sll_xc_deriv_get_rest,& 00078 cp_sll_xc_deriv_get_empty, cp_sll_xc_deriv_get_length,& 00079 cp_sll_xc_deriv_get_el_at, cp_sll_xc_deriv_set_el_at,& 00080 cp_sll_xc_deriv_insert_el, cp_sll_xc_deriv_insert_el_at,& 00081 cp_sll_xc_deriv_rm_first_el, cp_sll_xc_deriv_rm_el_at,& 00082 cp_sll_xc_deriv_rm_all_el, & 00083 cp_sll_xc_deriv_to_array,& 00084 cp_sll_xc_deriv_from_array, cp_sll_xc_deriv_insert_ordered,& 00085 cp_sll_xc_deriv_insert_ordered2 00086 00087 ! creation of an object (from a pointer) 00088 INTERFACE cp_create 00089 MODULE PROCEDURE cp_sll_xc_deriv_create 00090 END INTERFACE 00091 ! destruction of an object (from a pointer) 00092 INTERFACE cp_dealloc 00093 MODULE PROCEDURE cp_sll_xc_deriv_dealloc 00094 END INTERFACE 00095 ! destruction only of the node (low level) 00096 INTERFACE cp_dealloc_node 00097 MODULE PROCEDURE cp_sll_xc_deriv_dealloc_node 00098 END INTERFACE 00099 ! modifies attributes of an object 00100 INTERFACE cp_set 00101 MODULE PROCEDURE cp_sll_xc_deriv_set 00102 END INTERFACE 00103 ! returns attributes of an object 00104 INTERFACE cp_get 00105 MODULE PROCEDURE cp_sll_xc_deriv_get 00106 END INTERFACE 00107 ! iterates to the next element 00108 INTERFACE cp_next 00109 MODULE PROCEDURE cp_sll_xc_deriv_next 00110 END INTERFACE 00111 ! returns the first element 00112 INTERFACE cp_get_first_el 00113 MODULE PROCEDURE cp_sll_xc_deriv_get_first_el 00114 END INTERFACE 00115 ! returns the rest of the list 00116 INTERFACE cp_get_rest 00117 MODULE PROCEDURE cp_sll_xc_deriv_get_rest 00118 END INTERFACE 00119 ! returns if the list is empty 00120 INTERFACE cp_get_empty 00121 MODULE PROCEDURE cp_sll_xc_deriv_get_empty 00122 END INTERFACE 00123 ! returns the length of the list 00124 INTERFACE cp_get_length 00125 MODULE PROCEDURE cp_sll_xc_deriv_get_length 00126 END INTERFACE 00127 ! returns the element at the given position 00128 INTERFACE cp_get_element_at 00129 MODULE PROCEDURE cp_sll_xc_deriv_get_el_at 00130 END INTERFACE 00131 ! sets the element at the given position 00132 INTERFACE cp_set_element_at 00133 MODULE PROCEDURE cp_sll_xc_deriv_set_el_at 00134 END INTERFACE 00135 ! inserts one element call cp_insert(list,element,...) 00136 INTERFACE cp_insert 00137 MODULE PROCEDURE cp_sll_xc_deriv_insert_el 00138 END INTERFACE 00139 !MK INTERFACE cp_insert_ordered 00140 !MK MODULE PROCEDURE cp_sll_xc_deriv_insert_ordered,& 00141 !MK cp_sll_xc_deriv_insert_ordered2 00142 !MK END INTERFACE 00143 INTERFACE cp_insert_at 00144 MODULE PROCEDURE cp_sll_xc_deriv_insert_el_at 00145 END INTERFACE 00146 ! removes an element 00147 INTERFACE cp_remove_el 00148 MODULE PROCEDURE cp_sll_xc_deriv_rm_first_el, & 00149 cp_sll_xc_deriv_rm_el_at 00150 END INTERFACE 00151 ! removes the first el 00152 INTERFACE cp_remove_first_el 00153 MODULE PROCEDURE cp_sll_xc_deriv_rm_first_el 00154 END INTERFACE 00155 ! remove all the elments 00156 INTERFACE cp_remove_all 00157 MODULE PROCEDURE cp_sll_xc_deriv_rm_all_el 00158 END INTERFACE 00159 ! transorms the list in array 00160 INTERFACE cp_to_array 00161 MODULE PROCEDURE cp_sll_xc_deriv_to_array 00162 END INTERFACE 00163 00164 ! ***************************************************************************** 00186 TYPE cp_sll_xc_deriv_type 00187 TYPE(xc_derivative_type),POINTER :: first_el 00188 TYPE(cp_sll_xc_deriv_type), POINTER :: rest 00189 END TYPE cp_sll_xc_deriv_type 00190 00191 ! ***************************************************************************** 00198 TYPE cp_sll_xc_deriv_p_type 00199 TYPE(cp_sll_xc_deriv_type), POINTER :: list 00200 END TYPE cp_sll_xc_deriv_p_type 00201 00202 CONTAINS 00203 00204 !private compare function 00205 FUNCTION cp_sll_deriv_less_q(el1,el2,error) RESULT(res) 00206 TYPE(xc_derivative_type), POINTER :: el1, el2 00207 TYPE(cp_error_type), INTENT(inout) :: error 00208 LOGICAL :: res 00209 00210 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_deriv_less_q', 00211 routineP = moduleN//':'//routineN 00212 00213 CPPreconditionNoFail(ASSOCIATED(el1),cp_failure_level,routineP,error) 00214 CPPreconditionNoFail(ASSOCIATED(el1%split_desc),cp_failure_level,routineP,error) 00215 CPPreconditionNoFail(ASSOCIATED(el2),cp_failure_level,routineP,error) 00216 CPPreconditionNoFail(ASSOCIATED(el2%split_desc),cp_failure_level,routineP,error) 00217 res=SIZE(el1%split_desc)<SIZE(el2%split_desc).OR.& 00218 (SIZE(el1%split_desc)==SIZE(el2%split_desc).and.el1%desc<el2%desc) 00219 END FUNCTION 00220 00221 ! =========== creation / distruction ======== 00222 00223 ! ***************************************************************************** 00234 SUBROUTINE cp_sll_xc_deriv_create(sll,first_el,rest,error) 00235 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00236 TYPE(xc_derivative_type), OPTIONAL, 00237 POINTER :: first_el 00238 TYPE(cp_sll_xc_deriv_type), OPTIONAL, 00239 POINTER :: rest 00240 TYPE(cp_error_type), INTENT(inout) :: error 00241 00242 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_create', 00243 routineP = moduleN//':'//routineN 00244 00245 INTEGER :: stat 00246 LOGICAL :: failure 00247 00248 failure=.FALSE. 00249 00250 IF (.NOT.PRESENT(first_el)) THEN 00251 NULLIFY(sll) 00252 IF (PRESENT(rest)) sll => rest 00253 ELSE 00254 ALLOCATE(sll, stat=stat) 00255 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00256 IF (.NOT.failure) THEN 00257 sll%first_el => first_el 00258 NULLIFY(sll%rest) 00259 IF (PRESENT(rest)) sll%rest => rest 00260 END IF 00261 END IF 00262 IF (failure) NULLIFY(sll) 00263 END SUBROUTINE cp_sll_xc_deriv_create 00264 00265 ! ***************************************************************************** 00278 SUBROUTINE cp_sll_xc_deriv_dealloc(sll,error) 00279 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00280 TYPE(cp_error_type), INTENT(inout) :: error 00281 00282 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_dealloc', 00283 routineP = moduleN//':'//routineN 00284 00285 CALL cp_sll_xc_deriv_rm_all_el(sll,error) 00286 END SUBROUTINE cp_sll_xc_deriv_dealloc 00287 00288 ! * low-level * 00289 00290 ! ***************************************************************************** 00299 SUBROUTINE cp_sll_xc_deriv_dealloc_node(sll,error) 00300 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00301 TYPE(cp_error_type), INTENT(inout) :: error 00302 00303 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_dealloc_node', 00304 routineP = moduleN//':'//routineN 00305 00306 INTEGER :: stat 00307 LOGICAL :: failure 00308 00309 failure=.FALSE. 00310 00311 DEALLOCATE(sll, stat=stat) 00312 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00313 END SUBROUTINE cp_sll_xc_deriv_dealloc_node 00314 00315 ! ============= get/set ============ 00316 00317 ! ***************************************************************************** 00330 SUBROUTINE cp_sll_xc_deriv_set(sll,first_el,rest,error) 00331 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00332 TYPE(xc_derivative_type), OPTIONAL, 00333 POINTER :: first_el 00334 TYPE(cp_sll_xc_deriv_type), OPTIONAL, 00335 POINTER :: rest 00336 TYPE(cp_error_type), INTENT(inout) :: error 00337 00338 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_set', 00339 routineP = moduleN//':'//routineN 00340 00341 LOGICAL :: failure 00342 00343 failure=.FALSE. 00344 00345 IF (.NOT.ASSOCIATED(sll)) THEN 00346 IF (PRESENT(first_el)) THEN 00347 CALL cp_sll_xc_deriv_create(sll,first_el,rest,error) 00348 ELSE 00349 CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) 00350 END IF 00351 ELSE 00352 IF (PRESENT(first_el)) sll%first_el => first_el 00353 IF (PRESENT(rest)) sll%rest => rest 00354 END IF 00355 END SUBROUTINE cp_sll_xc_deriv_set 00356 00357 ! ***************************************************************************** 00369 SUBROUTINE cp_sll_xc_deriv_get(sll,first_el,rest,empty,length,error) 00370 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00371 TYPE(xc_derivative_type), OPTIONAL, 00372 POINTER :: first_el 00373 TYPE(cp_sll_xc_deriv_type), OPTIONAL, 00374 POINTER :: rest 00375 LOGICAL, INTENT(out), OPTIONAL :: empty 00376 INTEGER, INTENT(out), OPTIONAL :: length 00377 TYPE(cp_error_type), INTENT(inout) :: error 00378 00379 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get', 00380 routineP = moduleN//':'//routineN 00381 00382 LOGICAL :: failure 00383 00384 failure=.FALSE. 00385 00386 IF (.NOT.ASSOCIATED(sll)) THEN 00387 CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) 00388 IF (PRESENT(rest)) NULLIFY(rest) 00389 IF (PRESENT(empty)) empty=.TRUE. 00390 IF (PRESENT(length)) length=0 00391 ELSE 00392 IF (PRESENT(first_el)) first_el => sll%first_el 00393 IF (PRESENT(rest)) rest => sll%rest 00394 IF (PRESENT(empty)) empty = .FALSE. 00395 IF (PRESENT(length)) & 00396 length = cp_sll_xc_deriv_get_length(sll,error=error) 00397 END IF 00398 END SUBROUTINE cp_sll_xc_deriv_get 00399 00400 ! ***************************************************************************** 00409 FUNCTION cp_sll_xc_deriv_get_first_el(sll,error) RESULT(res) 00410 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00411 TYPE(cp_error_type), INTENT(inout) :: error 00412 TYPE(xc_derivative_type), POINTER :: res 00413 00414 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_first_el', 00415 routineP = moduleN//':'//routineN 00416 00417 LOGICAL :: failure 00418 00419 failure=.FALSE. 00420 00421 IF (cp_debug) THEN 00422 CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) 00423 END IF 00424 IF (.NOT. failure) THEN 00425 res => sll%first_el 00426 END IF 00427 END FUNCTION cp_sll_xc_deriv_get_first_el 00428 00429 ! ***************************************************************************** 00442 FUNCTION cp_sll_xc_deriv_get_rest(sll, iter, error) RESULT(res) 00443 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00444 INTEGER, OPTIONAL :: iter 00445 TYPE(cp_error_type), INTENT(inout) :: error 00446 TYPE(cp_sll_xc_deriv_type), POINTER :: res 00447 00448 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_rest', 00449 routineP = moduleN//':'//routineN 00450 00451 INTEGER :: i 00452 LOGICAL :: failure 00453 00454 failure=.FALSE. 00455 00456 IF (.NOT.ASSOCIATED(sll)) THEN 00457 NULLIFY(res) 00458 ELSE 00459 IF (.NOT. failure) THEN 00460 IF (PRESENT(iter)) THEN 00461 res => sll 00462 DO i=1,iter 00463 IF (ASSOCIATED(res%rest)) THEN 00464 res => res%rest 00465 ELSE 00466 CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& 00467 routineP, "tried to go past end in "// & 00468 CPSourceFileRef,& 00469 error,failure) 00470 END IF 00471 END DO 00472 IF (iter==-1) THEN 00473 DO 00474 IF (.NOT.ASSOCIATED(res%rest)) EXIT 00475 res => res%rest 00476 END DO 00477 END IF 00478 ELSE 00479 res => sll%rest ! make the common case fast... 00480 END IF 00481 ELSE 00482 NULLIFY(res) 00483 END IF 00484 END IF 00485 END FUNCTION cp_sll_xc_deriv_get_rest 00486 00487 ! ***************************************************************************** 00495 FUNCTION cp_sll_xc_deriv_get_empty(sll,error) RESULT(res) 00496 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00497 TYPE(cp_error_type), INTENT(inout) :: error 00498 LOGICAL :: res 00499 00500 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_empty', 00501 routineP = moduleN//':'//routineN 00502 00503 LOGICAL :: failure 00504 00505 failure=.FALSE. 00506 00507 res = .NOT.ASSOCIATED(sll) 00508 END FUNCTION cp_sll_xc_deriv_get_empty 00509 00510 ! ***************************************************************************** 00521 FUNCTION cp_sll_xc_deriv_get_length(sll,error) RESULT(res) 00522 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00523 TYPE(cp_error_type), INTENT(inout) :: error 00524 INTEGER :: res 00525 00526 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_length', 00527 routineP = moduleN//':'//routineN 00528 00529 LOGICAL :: failure 00530 TYPE(cp_sll_xc_deriv_type), POINTER :: iterator 00531 00532 failure=.FALSE. 00533 00534 res=0 00535 iterator => sll 00536 DO 00537 IF (ASSOCIATED(iterator)) THEN 00538 res=res+1 00539 iterator => iterator%rest 00540 ELSE 00541 EXIT 00542 END IF 00543 END DO 00544 END FUNCTION cp_sll_xc_deriv_get_length 00545 00546 ! ***************************************************************************** 00558 FUNCTION cp_sll_xc_deriv_get_el_at(sll,index,error) RESULT(res) 00559 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00560 INTEGER, INTENT(in) :: index 00561 TYPE(cp_error_type), INTENT(inout) :: error 00562 TYPE(xc_derivative_type), POINTER :: res 00563 00564 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_el_at', 00565 routineP = moduleN//':'//routineN 00566 00567 LOGICAL :: failure 00568 TYPE(cp_sll_xc_deriv_type), POINTER :: pos 00569 00570 failure=.FALSE. 00571 00572 IF (cp_debug) THEN 00573 CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) 00574 END IF 00575 IF (index==-1) THEN 00576 pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) 00577 ELSE 00578 pos => cp_sll_xc_deriv_get_rest(sll, iter=index-1,error=error) 00579 END IF 00580 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00581 IF (.NOT.failure) THEN 00582 res => pos%first_el 00583 END IF 00584 END FUNCTION cp_sll_xc_deriv_get_el_at 00585 00586 ! ***************************************************************************** 00600 SUBROUTINE cp_sll_xc_deriv_set_el_at(sll,index,value,error) 00601 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00602 INTEGER, INTENT(in) :: index 00603 TYPE(xc_derivative_type), POINTER :: value 00604 TYPE(cp_error_type), INTENT(inout) :: error 00605 00606 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_set_el_at', 00607 routineP = moduleN//':'//routineN 00608 00609 LOGICAL :: failure 00610 TYPE(cp_sll_xc_deriv_type), POINTER :: pos 00611 00612 failure=.FALSE. 00613 00614 IF (index==-1) THEN 00615 pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) 00616 ELSE 00617 pos => cp_sll_xc_deriv_get_rest(sll, iter=index-1,error=error) 00618 END IF 00619 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00620 IF (.NOT.failure) THEN 00621 pos%first_el => value 00622 END IF 00623 END SUBROUTINE cp_sll_xc_deriv_set_el_at 00624 00625 ! * iteration * 00626 00627 ! ***************************************************************************** 00638 FUNCTION cp_sll_xc_deriv_next(iterator,el_att,error) RESULT(res) 00639 TYPE(cp_sll_xc_deriv_type), POINTER :: iterator 00640 TYPE(xc_derivative_type), OPTIONAL, 00641 POINTER :: el_att 00642 TYPE(cp_error_type), INTENT(inout) :: error 00643 LOGICAL :: res 00644 00645 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_next', 00646 routineP = moduleN//':'//routineN 00647 00648 LOGICAL :: failure 00649 00650 failure=.FALSE. 00651 00652 IF (ASSOCIATED(iterator)) THEN 00653 res=.NOT.failure 00654 IF (PRESENT(el_att)) el_att => iterator%first_el 00655 iterator => iterator%rest 00656 ELSE 00657 res=.FALSE. 00658 END IF 00659 END FUNCTION cp_sll_xc_deriv_next 00660 00661 ! ============ structure modifications ============ 00662 00663 ! ***************************************************************************** 00676 SUBROUTINE cp_sll_xc_deriv_insert_el(sll,el,error) 00677 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00678 TYPE(xc_derivative_type), POINTER :: el 00679 TYPE(cp_error_type), INTENT(inout) :: error 00680 00681 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_insert_el', 00682 routineP = moduleN//':'//routineN 00683 00684 LOGICAL :: failure 00685 TYPE(cp_sll_xc_deriv_type), POINTER :: newSlot 00686 00687 failure=.FALSE. 00688 NULLIFY(newSlot) 00689 00690 CALL cp_sll_xc_deriv_create(newSlot,first_el=el,& 00691 rest=sll,error=error) 00692 sll => newSlot 00693 END SUBROUTINE cp_sll_xc_deriv_insert_el 00694 00695 ! ***************************************************************************** 00706 SUBROUTINE cp_sll_xc_deriv_rm_first_el(sll,error) 00707 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00708 TYPE(cp_error_type), INTENT(inout) :: error 00709 00710 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_rm_first_el', 00711 routineP = moduleN//':'//routineN 00712 00713 LOGICAL :: failure 00714 TYPE(cp_sll_xc_deriv_type), POINTER :: node_to_rm 00715 00716 failure=.FALSE. 00717 node_to_rm => sll 00718 00719 IF (ASSOCIATED(sll)) THEN 00720 sll => sll%rest 00721 CALL cp_sll_xc_deriv_dealloc_node(node_to_rm,error=error) 00722 ELSE 00723 CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& 00724 routineP,"tried to remove first el of an empty list in "//& 00725 CPSourceFileRef,& 00726 error,failure) 00727 END IF 00728 END SUBROUTINE cp_sll_xc_deriv_rm_first_el 00729 00730 ! ***************************************************************************** 00744 SUBROUTINE cp_sll_xc_deriv_insert_el_at(sll,el,index,error) 00745 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00746 TYPE(xc_derivative_type), POINTER :: el 00747 INTEGER, INTENT(in) :: index 00748 TYPE(cp_error_type), INTENT(inout) :: error 00749 00750 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_insert_el_at', 00751 routineP = moduleN//':'//routineN 00752 00753 LOGICAL :: failure 00754 TYPE(cp_sll_xc_deriv_type), POINTER :: pos 00755 00756 failure=.FALSE. 00757 00758 IF (index==1) THEN 00759 CALL cp_sll_xc_deriv_insert_el(sll,el,error=error) 00760 ELSE 00761 IF (index==-1) THEN 00762 pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) 00763 ELSE 00764 pos => cp_sll_xc_deriv_get_rest(sll, iter=index-2,error=error) 00765 END IF 00766 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00767 IF (.NOT.failure) THEN 00768 CALL cp_sll_xc_deriv_insert_el(pos%rest,el,error=error) 00769 END IF 00770 END IF 00771 END SUBROUTINE cp_sll_xc_deriv_insert_el_at 00772 00773 ! ***************************************************************************** 00786 SUBROUTINE cp_sll_xc_deriv_rm_el_at(sll,index,error) 00787 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00788 INTEGER, INTENT(in) :: index 00789 TYPE(cp_error_type), INTENT(inout) :: error 00790 00791 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_rm_el_at', 00792 routineP = moduleN//':'//routineN 00793 00794 LOGICAL :: failure 00795 TYPE(cp_sll_xc_deriv_type), POINTER :: pos 00796 00797 failure=.FALSE. 00798 00799 IF (cp_debug) THEN 00800 CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) 00801 END IF 00802 IF (index==1) THEN 00803 CALL cp_sll_xc_deriv_rm_first_el(sll,error=error) 00804 ELSE 00805 IF (index==-1) THEN 00806 pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) 00807 ELSE 00808 pos => cp_sll_xc_deriv_get_rest(sll, iter=index-2,error=error) 00809 END IF 00810 CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) 00811 IF (.NOT.failure) THEN 00812 CALL cp_sll_xc_deriv_rm_first_el(pos%rest,error=error) 00813 END IF 00814 END IF 00815 END SUBROUTINE cp_sll_xc_deriv_rm_el_at 00816 00817 ! ***************************************************************************** 00828 SUBROUTINE cp_sll_xc_deriv_rm_all_el(sll,error) 00829 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00830 TYPE(cp_error_type), INTENT(inout) :: error 00831 00832 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_rm_all_el', 00833 routineP = moduleN//':'//routineN 00834 00835 LOGICAL :: failure 00836 TYPE(cp_sll_xc_deriv_type), POINTER :: actual_node, next_node 00837 00838 failure=.FALSE. 00839 00840 actual_node => sll 00841 DO 00842 IF (.NOT.ASSOCIATED(actual_node)) EXIT 00843 next_node => actual_node%rest 00844 CALL cp_sll_xc_deriv_dealloc_node(actual_node,error=error) 00845 actual_node => next_node 00846 END DO 00847 NULLIFY(sll) 00848 END SUBROUTINE cp_sll_xc_deriv_rm_all_el 00849 00850 ! ***************************************************************************** 00860 FUNCTION cp_sll_xc_deriv_to_array(sll,error) RESULT(res) 00861 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00862 TYPE(cp_error_type), INTENT(inout) :: error 00863 TYPE(xc_derivative_p_type), 00864 DIMENSION(:), POINTER :: res 00865 00866 INTEGER :: i, len, stat 00867 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_to_array', 00868 routineP = moduleN//':'//routineN 00869 00870 LOGICAL :: failure 00871 TYPE(cp_sll_xc_deriv_type), POINTER :: iter 00872 00873 failure=.FALSE. 00874 00875 len=cp_sll_xc_deriv_get_length(sll,error) 00876 ALLOCATE(res(len),stat=stat) 00877 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00878 IF (.NOT. failure) THEN 00879 iter => sll 00880 DO i=1,len 00881 res(i)%deriv => iter%first_el 00882 IF (.NOT.(cp_sll_xc_deriv_next(iter,error=error).OR.i==len)) THEN 00883 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00884 END IF 00885 END DO 00886 END IF 00887 END FUNCTION cp_sll_xc_deriv_to_array 00888 00889 ! ***************************************************************************** 00898 FUNCTION cp_sll_xc_deriv_from_array(array,error) RESULT(res) 00899 TYPE(xc_derivative_p_type), 00900 DIMENSION(:), INTENT(in) :: array 00901 TYPE(cp_error_type), INTENT(inout) :: error 00902 TYPE(cp_sll_xc_deriv_type), POINTER :: res 00903 00904 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_from_array', 00905 routineP = moduleN//':'//routineN 00906 00907 INTEGER :: i 00908 LOGICAL :: failure 00909 TYPE(cp_sll_xc_deriv_type), POINTER :: last_el 00910 00911 failure=.FALSE. 00912 00913 NULLIFY(res,last_el) 00914 IF (SIZE(array)>0) THEN 00915 CALL cp_sll_xc_deriv_create(res,& 00916 first_el=array(1)%deriv,& 00917 error=error) 00918 last_el => res 00919 END IF 00920 DO i=2,SIZE(array) 00921 CALL cp_sll_xc_deriv_create(last_el%rest,& 00922 first_el=array(i)%deriv,& 00923 error=error) 00924 last_el => last_el%rest 00925 END DO 00926 END FUNCTION cp_sll_xc_deriv_from_array 00927 00928 ! ***************************************************************************** 00943 SUBROUTINE cp_sll_xc_deriv_insert_ordered(sll,el,insert_equals,& 00944 did_insert,pos,error) 00945 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 00946 TYPE(xc_derivative_type), POINTER :: el 00947 LOGICAL, INTENT(in), OPTIONAL :: insert_equals 00948 LOGICAL, INTENT(out), OPTIONAL :: did_insert 00949 TYPE(cp_sll_xc_deriv_type), OPTIONAL, 00950 POINTER :: pos 00951 TYPE(cp_error_type), INTENT(inout) :: error 00952 00953 CHARACTER(len=*), PARAMETER :: 00954 routineN = 'cp_sll_xc_deriv_insert_ordered', 00955 routineP = moduleN//':'//routineN 00956 00957 LOGICAL :: failure, i_eq 00958 TYPE(cp_sll_xc_deriv_type), POINTER :: iter 00959 00960 failure=.FALSE. 00961 i_eq=.FALSE. 00962 00963 IF (PRESENT(did_insert)) did_insert=.FALSE. 00964 IF (PRESENT(pos)) NULLIFY(pos) 00965 00966 IF (PRESENT(insert_equals)) i_eq=insert_equals 00967 IF (.NOT.ASSOCIATED(sll)) THEN 00968 CALL cp_sll_xc_deriv_create(sll,first_el=el,error=error) 00969 IF (PRESENT(did_insert)) did_insert=.TRUE. 00970 IF (PRESENT(pos)) pos=>sll 00971 ELSE IF (.NOT.cp_sll_deriv_less_q(sll%first_el,el,error=error)) THEN 00972 IF (PRESENT(pos)) pos=>sll 00973 IF (i_eq.OR.cp_sll_deriv_less_q(el,sll%first_el,error=error)) THEN 00974 CALL cp_sll_xc_deriv_insert_el(sll,el,error=error) 00975 IF (PRESENT(did_insert)) did_insert=.TRUE. 00976 IF (PRESENT(pos)) pos=>sll 00977 END IF 00978 ELSE 00979 iter => sll 00980 DO 00981 IF (.NOT.ASSOCIATED(iter%rest)) THEN 00982 CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) 00983 IF (PRESENT(did_insert)) did_insert=.TRUE. 00984 IF (PRESENT(pos)) pos=>iter%rest 00985 EXIT 00986 ELSE IF (.NOT.cp_sll_deriv_less_q(iter%rest%first_el,el,error=error)) THEN 00987 IF (PRESENT(pos)) pos=>iter 00988 IF (i_eq.OR. cp_sll_deriv_less_q(el,iter%rest%first_el,error=error)) THEN 00989 CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) 00990 IF (PRESENT(did_insert)) did_insert=.TRUE. 00991 IF (PRESENT(pos)) pos=>iter%rest 00992 END IF 00993 EXIT 00994 END IF 00995 CPInvariant(cp_sll_xc_deriv_next(iter,error=error),cp_failure_level,routineP,error,failure) 00996 END DO 00997 CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) 00998 END IF 00999 END SUBROUTINE cp_sll_xc_deriv_insert_ordered 01000 01001 ! ***************************************************************************** 01016 SUBROUTINE cp_sll_xc_deriv_insert_ordered2(sll,el,compare_function,& 01017 insert_equals,did_insert,pos,error) 01018 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 01019 TYPE(xc_derivative_type), POINTER :: el 01020 INTERFACE 01021 ! ***************************************************************************** 01022 FUNCTION compare_function(el1,el2) 01023 USE kinds, ONLY: dp 01024 USE xc_derivative_types, ONLY: xc_derivative_type,xc_derivative_p_type 01025 INTEGER :: compare_function 01026 TYPE(xc_derivative_type),POINTER :: el1,el2 01027 END FUNCTION compare_function 01028 END INTERFACE 01029 LOGICAL, INTENT(in), OPTIONAL :: insert_equals 01030 LOGICAL, INTENT(out), OPTIONAL :: did_insert 01031 TYPE(cp_sll_xc_deriv_type), OPTIONAL, 01032 POINTER :: pos 01033 TYPE(cp_error_type), INTENT(inout) :: error 01034 01035 CHARACTER(len=*), PARAMETER :: 01036 routineN = 'cp_sll_xc_deriv_insert_ordered2', 01037 routineP = moduleN//':'//routineN 01038 01039 INTEGER :: comp 01040 LOGICAL :: failure, i_eq 01041 TYPE(cp_sll_xc_deriv_type), POINTER :: iter 01042 01043 failure=.FALSE. 01044 i_eq=.FALSE. 01045 01046 IF (PRESENT(did_insert)) did_insert=.FALSE. 01047 IF (PRESENT(pos)) NULLIFY(pos) 01048 01049 IF (PRESENT(insert_equals)) i_eq=insert_equals 01050 IF (.NOT.ASSOCIATED(sll)) THEN 01051 CALL cp_sll_xc_deriv_create(sll,first_el=el,error=error) 01052 IF (PRESENT(did_insert)) did_insert=.TRUE. 01053 IF (PRESENT(pos)) pos=>sll%rest 01054 RETURN 01055 END IF 01056 comp=compare_function(sll%first_el,el) 01057 IF (comp>=0) THEN 01058 IF (i_eq.OR.comp/=0) THEN 01059 CALL cp_sll_xc_deriv_insert_el(sll,el,error=error) 01060 IF (PRESENT(did_insert)) did_insert=.TRUE. 01061 IF (PRESENT(pos)) pos=>sll%rest 01062 END IF 01063 ELSE 01064 iter => sll 01065 DO 01066 IF (.NOT.ASSOCIATED(iter%rest)) THEN 01067 CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) 01068 IF (PRESENT(did_insert)) did_insert=.TRUE. 01069 IF (PRESENT(pos)) pos=>iter%rest 01070 EXIT 01071 END IF 01072 comp=compare_function(iter%rest%first_el,el) 01073 IF (comp>=0) THEN 01074 IF (i_eq.OR. comp/=0) THEN 01075 CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) 01076 IF (PRESENT(did_insert)) did_insert=.TRUE. 01077 IF (PRESENT(pos)) pos=>iter%rest 01078 END IF 01079 EXIT 01080 END IF 01081 CPInvariant(cp_sll_xc_deriv_next(iter,error=error),cp_failure_level,routineP,error,failure) 01082 END DO 01083 CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) 01084 END IF 01085 END SUBROUTINE cp_sll_xc_deriv_insert_ordered2 01086 01087 ! ***************************************************************************** 01101 FUNCTION cp_sll_xc_deriv_contains(sll,el,ordered,error) RESULT(res) 01102 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 01103 TYPE(xc_derivative_type), POINTER :: el 01104 LOGICAL, INTENT(in), OPTIONAL :: ordered 01105 TYPE(cp_error_type), INTENT(inout) :: error 01106 LOGICAL :: res 01107 01108 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_contains', 01109 routineP = moduleN//':'//routineN 01110 01111 LOGICAL :: failure, ord 01112 TYPE(cp_sll_xc_deriv_type), POINTER :: iter 01113 TYPE(xc_derivative_type), POINTER :: el_att 01114 01115 failure=.FALSE.; ord=.FALSE. 01116 res=.FALSE. 01117 01118 iter => sll 01119 IF (PRESENT(ordered)) ord=ordered 01120 IF (ord) THEN 01121 DO 01122 IF (.NOT.cp_sll_xc_deriv_next(iter,el_att=el_att,error=error)) EXIT 01123 IF (.NOT.cp_sll_deriv_less_q(el_att,el,error=error)) THEN 01124 res=.NOT.cp_sll_deriv_less_q(el,el_att,error=error) 01125 RETURN 01126 END IF 01127 END DO 01128 ELSE 01129 DO 01130 IF (.NOT.cp_sll_xc_deriv_next(iter,el_att=el_att,error=error)) EXIT 01131 IF (.NOT.CP_SLL_DERIV_EQUAL_Q(el_att,el,error)) THEN 01132 res=.TRUE. 01133 RETURN 01134 END IF 01135 END DO 01136 END IF 01137 END FUNCTION cp_sll_xc_deriv_contains 01138 01139 ! ***************************************************************************** 01156 FUNCTION cp_sll_xc_deriv_contains2(sll,el,compare_function,ordered,error)& 01157 RESULT(res) 01158 TYPE(cp_sll_xc_deriv_type), POINTER :: sll 01159 TYPE(xc_derivative_type), POINTER :: el 01160 INTERFACE 01161 ! ***************************************************************************** 01162 FUNCTION compare_function(el1,el2) 01163 USE kinds, ONLY: dp 01164 USE xc_derivative_types, ONLY: xc_derivative_type,xc_derivative_p_type 01165 INTEGER :: compare_function 01166 TYPE(xc_derivative_type),POINTER :: el1,el2 01167 END FUNCTION compare_function 01168 END INTERFACE 01169 LOGICAL, INTENT(in), OPTIONAL :: ordered 01170 TYPE(cp_error_type), INTENT(inout) :: error 01171 LOGICAL :: res 01172 01173 CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_contains2', 01174 routineP = moduleN//':'//routineN 01175 01176 INTEGER :: comp 01177 LOGICAL :: failure 01178 TYPE(cp_sll_xc_deriv_type), POINTER :: iter 01179 TYPE(xc_derivative_type), POINTER :: el_att 01180 01181 failure=.FALSE. 01182 res=.FALSE. 01183 01184 iter => sll 01185 IF (ordered) THEN 01186 DO 01187 IF (.NOT.cp_sll_xc_deriv_next(iter,el_att=el_att,error=error)) EXIT 01188 comp=compare_function(el_att,el) 01189 IF (comp>=0) THEN 01190 res= comp==0 01191 RETURN 01192 END IF 01193 END DO 01194 ELSE 01195 DO 01196 IF (.NOT.cp_sll_xc_deriv_next(iter,el_att=el_att,error=error)) EXIT 01197 IF (compare_function(el_att,el)==0) THEN 01198 res=.TRUE. 01199 RETURN 01200 END IF 01201 END DO 01202 END IF 01203 END FUNCTION cp_sll_xc_deriv_contains2 01204 01205 ! template def put here so that line numbers in template and derived 01206 ! files are almost the same (multi-line use change it a bit) 01207 ! [template(defines,nametype1,type1,type1in,type1out,type1arrayEl,arrayEl,array=,=,USE,write_el,lessQ,equalQ,private_routines)] 01208 ! ARGS: 01209 ! = = "=>" 01210 ! USE = 01211 ! "USE kinds, only: dp 01212 ! USE xc_derivative_types, only: xc_derivative_type,xc_derivative_p_type" 01213 ! array= = "=>" 01214 ! arrayEl = "%deriv" 01215 ! defines = 01216 ! "#define CP_SLL_DERIV_LESS_Q(el1,el2,error) cp_sll_deriv_less_q(el1,el2,error) 01217 ! #define CP_SLL_DERIV_EQUAL_Q(el1,el2,error) ( el1%desc == el2%desc ) 01218 ! " 01219 ! equalQ = "CP_SLL_DERIV_EQUAL_Q" 01220 ! lessQ = "cp_sll_deriv_less_q" 01221 ! nametype1 = "xc_deriv" 01222 ! private_routines = 01223 ! "!private compare function 01224 ! function cp_sll_deriv_less_q(el1,el2,error) result(res) 01225 ! type(xc_derivative_type), pointer :: el1,el2 01226 ! type(cp_error_type), intent(inout) :: error 01227 ! logical :: res 01228 ! 01229 ! character(len=*),parameter :: routineN='cp_sll_deriv_less_q',& 01230 ! routineP=moduleN//':'//routineN 01231 ! 01232 ! CPPreconditionNoFail(associated(el1),cp_failure_level,routineP,error) 01233 ! CPPreconditionNoFail(associated(el1%split_desc),cp_failure_level,routineP,error) 01234 ! CPPreconditionNoFail(associated(el2),cp_failure_level,routineP,error) 01235 ! CPPreconditionNoFail(associated(el2%split_desc),cp_failure_level,routineP,error) 01236 ! res=size(el1%split_desc)<size(el2%split_desc).or.& 01237 ! (size(el1%split_desc)==size(el2%split_desc).and.el1%desc<el2%desc) 01238 ! end function 01239 ! " 01240 ! type1 = "type(xc_derivative_type),pointer" 01241 ! type1arrayEl = "type(xc_derivative_p_type)" 01242 ! type1in = "type(xc_derivative_type),pointer" 01243 ! type1out = "type(xc_derivative_type),pointer" 01244 ! write_el = "" 01245 01246 01247 END MODULE cp_linked_list_xc_deriv 01248
1.7.3