1! ----------------------------------------------------------------- 2! Programmer(s): Cody J. Balos @ LLNL 3! ----------------------------------------------------------------- 4! Acknowledgements: These testing routines are based on 5! test_nvector.c written by David Gardner and Slaven Peles @ LLNL. 6! ----------------------------------------------------------------- 7! SUNDIALS Copyright Start 8! Copyright (c) 2002-2020, Lawrence Livermore National Security 9! and Southern Methodist University. 10! All rights reserved. 11! 12! See the top-level LICENSE and NOTICE files for details. 13! 14! SPDX-License-Identifier: BSD-3-Clause 15! SUNDIALS Copyright End 16! ----------------------------------------------------------------- 17! These test functions are designed to check the fortran interface 18! to an NVECTOR module implementation. It does not test every 19! function. It tests the N_VMake constructor, one standard vector 20! operation (N_VConst), N_VGetArrayPointer, and one fused operation. 21! ----------------------------------------------------------------- 22 23module test_fnvector 24 use, intrinsic :: iso_c_binding 25 use fsundials_nvector_mod 26 use fsundials_types_mod 27 use test_utilities 28 implicit none 29 30 integer(C_INT), external :: check_ans 31 logical, external :: has_data 32 33contains 34 35 36integer(C_INT) function Test_FN_VMake(X, local_length, myid) & 37 result(failure) 38 implicit none 39 40 type(N_Vector) :: X 41 integer(C_LONG) :: local_length 42 integer(C_INT) :: myid 43 44 if (.not. has_data(X)) then 45 print *, '(I4)', '>>> FAILED test -- FN_VMake, Proc ', myid 46 print *, ' vector data is not associated' 47 failure = 1 48 return 49 end if 50 51 if (myid == 0) then 52 print *, 'PASSED test -- FN_VMake' 53 end if 54 55 failure = 0 56end function Test_FN_VMake 57 58 59!! ---------------------------------------------------------------------- 60!! NOTE: This routine depends on FN_VConst to check vector data. 61!! ---------------------------------------------------------------------- 62integer(C_INT) function Test_FN_VGetArrayPointer(W, local_length, myid) & 63 result(failure) 64 implicit none 65 66 type(N_Vector) :: W 67 integer(C_LONG) :: local_length 68 integer(C_INT) :: myid 69 70 ! check vector data 71 if (.not. has_data(W)) then 72 print *, '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid 73 print *, ' Vector data == NULL \n\n' 74 failure = 1 75 return; 76 end if 77 78 call FN_VConst(NEG_HALF, W) 79 failure = check_ans(NEG_HALF, W, local_length) 80 81 if (failure > 0) then 82 print *, '(I2)', '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid 83 print *, ' Failed FN_VConst check \n\n' 84 failure = 1 85 return 86 end if 87 88 if (myid == 0) then 89 print *, 'PASSED test -- FN_VConst' 90 print *, 'PASSED test -- FN_VGetArrayPointer' 91 end if 92 93 failure = 0 94end function Test_FN_VGetArrayPointer 95 96 97integer(C_INT) function Test_FN_VLinearCombination(X, local_length, myid) & 98 result(failure) 99 100 type(N_Vector) :: X 101 integer(C_LONG) :: local_length 102 integer(C_INT) :: myid, ierr 103 type(N_Vector), pointer :: Y1, Y2, Y3 104 type(c_ptr), target :: V(3) 105 type(c_ptr) :: Vptr 106 real(C_DOUBLE) :: c(3) 107 108 failure = 0 109 110 ! create vectors for testing 111 Y1 => FN_VClone(X) 112 Y2 => FN_VClone(X) 113 Y3 => FN_VClone(X) 114 115 ! set vectors in vector array 116 V = (/c_loc(Y1), c_loc(Y2), c_loc(Y3)/) 117 Vptr = c_loc(V) 118 119 ! initialize c values 120 c = ZERO 121 122 ! 123 ! Case 1a: V[0] = a V[0], FN_VScale 124 ! 125 126 ! fill vector data 127 call FN_VConst(TWO, Y1) 128 129 ! set scaling factors 130 c = HALF 131 132 ierr = FN_VLinearCombination(1, c, Vptr, Y1) 133 134 ! Y1 should be vector of +1 135 if (ierr == 0) then 136 failure = check_ans(ONE, Y1, local_length) 137 else 138 failure = 1 139 end if 140 141 if (failure > 0) then 142 print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 1a, Proc ', myid 143 else if (myid == 0) then 144 print *, 'PASSED test -- FN_VLinearCombination Case 1a' 145 end if 146 147 ! 148 ! Case 3a: V[0] = V[0] + b V[1] + c V[2] 149 ! 150 151 call FN_VConst(TWO, Y1) 152 call FN_VConst(NEG_TWO, Y2) 153 call FN_VConst(NEG_ONE, Y3) 154 155 c(1) = ONE 156 c(2) = HALF 157 c(3) = NEG_TWO 158 159 ierr = FN_VLinearCombination(3, c, Vptr, Y1) 160 161 ! Y1 should be vector of +3 162 if (ierr == 0) then 163 failure = check_ans(TWO+ONE, Y1, local_length) 164 else 165 failure = 1 166 end if 167 168 if (failure > 0) then 169 print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 3a, Proc ', myid 170 else if (myid == 0) then 171 print *, 'PASSED test -- FN_VLinearCombination Case 3a' 172 end if 173 174 ! Free vectors 175 call FN_VDestroy(Y1); 176 call FN_VDestroy(Y2); 177 call FN_VDestroy(Y3); 178 179end function Test_FN_VLinearCombination 180 181end module 182