diff --git a/.github/workflows/check-clang-format.yml b/.github/workflows/check-clang-format.yml index 0e2e6dab52..2a87a2a35d 100644 --- a/.github/workflows/check-clang-format.yml +++ b/.github/workflows/check-clang-format.yml @@ -13,7 +13,10 @@ jobs: - name: Install git run: | apt update - apt install -y git + apt install -y git python3-pip + + - name: Install fprettify + run: pip install fprettify - name: Check out repository code uses: actions/checkout@v4 diff --git a/doc/superbuild/source/developers/style_guide/SourceCode.rst b/doc/superbuild/source/developers/style_guide/SourceCode.rst index c9105fa99c..473409d987 100644 --- a/doc/superbuild/source/developers/style_guide/SourceCode.rst +++ b/doc/superbuild/source/developers/style_guide/SourceCode.rst @@ -185,7 +185,8 @@ not adhere to all of these rules. library which requires a newer standard. #. All new code added to SUNDIALS should be - formatted with `clang-format `_. + formatted with `clang-format `_, + and `fprettify `_. See :ref:`Style.Formatting` for details. #. Spaces not tabs. @@ -377,9 +378,11 @@ Formatting ---------- All new code added to SUNDIALS should be formatted with `clang-format -`_. The -``.clang-format`` files in the root of the project define our configurations -for the tools respectively. To apply clang-format you can run: +`_ and +`fprettify `_. The +``.clang-format`` file in the root of the project defines our configuration +for clang-format. We use the default fprettify settings, except we use +2-space indentation. To apply ``clang-format`` and ``fprettify`` you can run: .. code-block:: shell diff --git a/examples/arkode/F2003_custom/ark_analytic_complex_f2003.f90 b/examples/arkode/F2003_custom/ark_analytic_complex_f2003.f90 index 83e9ac1fbf..ad1c64c8fa 100644 --- a/examples/arkode/F2003_custom/ark_analytic_complex_f2003.f90 +++ b/examples/arkode/F2003_custom/ark_analytic_complex_f2003.f90 @@ -39,14 +39,14 @@ module ode_mod !======= Declarations ========= implicit none - integer(c_int64_t), parameter :: neq = 1 - integer(c_int), parameter :: Nt = 10 - complex(c_double_complex), parameter :: lambda = (-1d-2, 10.d0) - real(c_double), parameter :: T0 = 0.d0 - real(c_double), parameter :: Tf = 10.d0 - real(c_double), parameter :: dtmax = 0.01d0 - real(c_double), parameter :: reltol = 1.d-6 - real(c_double), parameter :: abstol = 1.d-10 + integer(c_int64_t), parameter :: neq = 1 + integer(c_int), parameter :: Nt = 10 + complex(c_double_complex), parameter :: lambda = (-1d-2, 10.d0) + real(c_double), parameter :: T0 = 0.d0 + real(c_double), parameter :: Tf = 10.d0 + real(c_double), parameter :: dtmax = 0.01d0 + real(c_double), parameter :: reltol = 1.d-6 + real(c_double), parameter :: abstol = 1.d-10 contains @@ -60,7 +60,7 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function Rhs(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='Rhs') + result(ierr) bind(C, name='Rhs') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -147,13 +147,13 @@ program main print *, " " print *, "Analytical ODE test problem:" print '(2(a,f5.2),a)', " lambda = (", real(lambda), " , ", imag(lambda), " ) " - print '(2(a,es8.1))', " reltol = ",reltol,", abstol = ",abstol + print '(2(a,es8.1))', " reltol = ", reltol, ", abstol = ", abstol ! initialize SUNDIALS solution vector sunvec_y => FN_VNew_Complex(neq, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if y => FN_VGetFVec(sunvec_y) @@ -163,43 +163,43 @@ program main ! create ARKStep memory arkode_mem = FARKStepCreate(c_funloc(Rhs), c_null_funptr, T0, sunvec_y, sunctx) if (.not. c_associated(arkode_mem)) then - print *,'ERROR: arkode_mem = NULL' - stop 1 + print *, 'ERROR: arkode_mem = NULL' + stop 1 end if ! main time-stepping loop: calls FARKodeEvolve to perform the integration, then ! prints results. Stops when the final time has been reached tcur(1) = T0 - dTout = (Tf-T0)/Nt - tout = T0+dTout + dTout = (Tf - T0)/Nt + tout = T0 + dTout yerrI = 0.d0 yerr2 = 0.d0 print *, " " print *, " t real(u) imag(u) error" print *, " -------------------------------------------" print '(5x,f4.1,2(2x,es9.2),2x,es8.1)', tcur(1), real(y%data(1)), imag(y%data(1)), 0.d0 - do iout = 1,Nt + do iout = 1, Nt - ! call integrator - ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) - if (ierr /= 0) then - write(*,*) 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' - stop 1 - endif + ! call integrator + ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) + if (ierr /= 0) then + write (*, *) 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' + stop 1 + end if - ! compute/accumulate solution error - yerr = abs( y%data(1) - Sol(tcur(1)) ) - yerrI = max(yerrI, yerr) - yerr2 = yerr2 + yerr**2 + ! compute/accumulate solution error + yerr = abs(y%data(1) - Sol(tcur(1))) + yerrI = max(yerrI, yerr) + yerr2 = yerr2 + yerr**2 - ! print solution statistics - print '(5x,f4.1,2(2x,es9.2),2x,es8.1)', tcur(1), real(y%data(1)), imag(y%data(1)), yerr + ! print solution statistics + print '(5x,f4.1,2(2x,es9.2),2x,es8.1)', tcur(1), real(y%data(1)), imag(y%data(1)), yerr - ! update output time - tout = min(tout + dTout, Tf) + ! update output time + tout = min(tout + dTout, Tf) end do - yerr2 = dsqrt( yerr2 / Nt ) + yerr2 = dsqrt(yerr2/Nt) print *, " -------------------------------------------" ! diagnostics output @@ -214,7 +214,6 @@ program main end program main - ! ---------------------------------------------------------------- ! ARKStepStats ! @@ -248,9 +247,9 @@ subroutine ARKStepStats(arkode_mem) print *, ' ' print *, 'Final Solver Statistics:' - print '(4x,2(A,i4),A)' ,'Internal solver steps = ',nsteps(1),', (attempted = ',nst_a(1),')' - print '(4x,A,i5)' ,'Total RHS evals = ',nfe(1) - print '(4x,A,i5)' ,'Total number of error test failures =',netfails(1) + print '(4x,2(A,i4),A)', 'Internal solver steps = ', nsteps(1), ', (attempted = ', nst_a(1), ')' + print '(4x,A,i5)', 'Total RHS evals = ', nfe(1) + print '(4x,A,i5)', 'Total number of error test failures =', netfails(1) return diff --git a/examples/arkode/F2003_custom/ark_brusselator1D_f2003.f90 b/examples/arkode/F2003_custom/ark_brusselator1D_f2003.f90 index c195ce2d12..71e577acd5 100644 --- a/examples/arkode/F2003_custom/ark_brusselator1D_f2003.f90 +++ b/examples/arkode/F2003_custom/ark_brusselator1D_f2003.f90 @@ -55,17 +55,17 @@ module ode_mod integer(c_long), parameter :: Nt = 100 ! total number of output times integer(c_int64_t), parameter :: Nvar = 3 ! number of solution fields integer(c_int64_t), parameter :: neq = N*Nvar ! total size of solution vector - real(c_double), parameter :: dx = 1.d0/(N-1) ! mesh spacing - real(c_double), parameter :: a = 0.6d0 ! constant forcing on u - real(c_double), parameter :: b = 2.d0 ! steady-state value of w - real(c_double), parameter :: du = 0.001d0 ! diffusion coeff for u - real(c_double), parameter :: dv = 0.001d0 ! diffusion coeff for v - real(c_double), parameter :: dw = 0.001d0 ! diffusion coeff for w - real(c_double), parameter :: ep = 1.d-5 ! stiffness parameter - real(c_double), parameter :: T0 = 0.d0 ! initial time - real(c_double), parameter :: Tf = 10.d0 ! final time - real(c_double), parameter :: reltol = 1.d-6 ! solver tolerances - real(c_double), parameter :: abstol = 1.d-10 + real(c_double), parameter :: dx = 1.d0/(N - 1) ! mesh spacing + real(c_double), parameter :: a = 0.6d0 ! constant forcing on u + real(c_double), parameter :: b = 2.d0 ! steady-state value of w + real(c_double), parameter :: du = 0.001d0 ! diffusion coeff for u + real(c_double), parameter :: dv = 0.001d0 ! diffusion coeff for v + real(c_double), parameter :: dw = 0.001d0 ! diffusion coeff for w + real(c_double), parameter :: ep = 1.d-5 ! stiffness parameter + real(c_double), parameter :: T0 = 0.d0 ! initial time + real(c_double), parameter :: Tf = 10.d0 ! final time + real(c_double), parameter :: reltol = 1.d-6 ! solver tolerances + real(c_double), parameter :: abstol = 1.d-10 contains @@ -80,7 +80,7 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsImplicit(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsImplicit') + result(ierr) bind(C, name='RhsImplicit') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -106,27 +106,27 @@ integer(c_int) function RhsImplicit(tn, sunvec_y, sunvec_f, user_data) & call c_f_pointer(sunvec_f%content, f) ! iterate over domain, computing all equations - do i = 2,N-1 + do i = 2, N - 1 - ! set solution variable shortcuts - u = y%data(1,i) - v = y%data(2,i) - w = y%data(3,i) + ! set solution variable shortcuts + u = y%data(1, i) + v = y%data(2, i) + w = y%data(3, i) - ! Fill in ODE RHS for u - f%data(1,i) = a - (w+1.d0)*u + v*u*u + ! Fill in ODE RHS for u + f%data(1, i) = a - (w + 1.d0)*u + v*u*u - ! Fill in ODE RHS for v - f%data(2,i) = w*u - v*u*u + ! Fill in ODE RHS for v + f%data(2, i) = w*u - v*u*u - ! Fill in ODE RHS for w - f%data(3,i) = (b-w)/ep - w*u + ! Fill in ODE RHS for w + f%data(3, i) = (b - w)/ep - w*u end do ! enforce stationary boundary conditions - f%data(:,1) = 0.d0 - f%data(:,N) = 0.d0 + f%data(:, 1) = 0.d0 + f%data(:, N) = 0.d0 ! return success ierr = 0 @@ -144,7 +144,7 @@ end function RhsImplicit ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsExplicit(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsExplicit') + result(ierr) bind(C, name='RhsExplicit') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -170,18 +170,18 @@ integer(c_int) function RhsExplicit(tn, sunvec_y, sunvec_f, user_data) & call c_f_pointer(sunvec_f%content, f) ! set shortcut variables - dconst = (/ du/dx/dx, dv/dx/dx, dw/dx/dx /) + dconst = (/du/dx/dx, dv/dx/dx, dw/dx/dx/) ! Fill in diffusion RHS for each species - do j = 2,N-1 - do i = 1,Nvar - f%data(i,j) = (y%data(i,j-1) + y%data(i,j+1) - 2.d0*y%data(i,j))*dconst(i) - end do + do j = 2, N - 1 + do i = 1, Nvar + f%data(i, j) = (y%data(i, j - 1) + y%data(i, j + 1) - 2.d0*y%data(i, j))*dconst(i) + end do end do ! enforce stationary boundary conditions - f%data(:,1) = 0.d0 - f%data(:,N) = 0.d0 + f%data(:, 1) = 0.d0 + f%data(:, N) = 0.d0 ! return success ierr = 0 @@ -198,8 +198,8 @@ end function RhsExplicit ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & - user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='JacFn') + user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='JacFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -231,27 +231,27 @@ integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & call c_f_pointer(sunmat_J%content, J) ! iterate over domain, computing all Jacobian entries - do i = 2,N-1 + do i = 2, N - 1 - ! set solution variable shortcuts - u = y%data(1,i) - v = y%data(2,i) - w = y%data(3,i) + ! set solution variable shortcuts + u = y%data(1, i) + v = y%data(2, i) + w = y%data(3, i) - ! Fill in Jacobian of all variables wrt u - J%data(:,1,i) = (/ 2.d0*v*u - (w+1.d0), w - 2.d0*v*u, -w /) + ! Fill in Jacobian of all variables wrt u + J%data(:, 1, i) = (/2.d0*v*u - (w + 1.d0), w - 2.d0*v*u, -w/) - ! Fill in Jacobian of all variables wrt v - J%data(:,2,i) = (/ u*u, -u*u, 0.d0 /) + ! Fill in Jacobian of all variables wrt v + J%data(:, 2, i) = (/u*u, -u*u, 0.d0/) - ! Fill in Jacobian of all variables wrt w - J%data(:,3,i) = (/ -u, u, -1.d0/ep - u/) + ! Fill in Jacobian of all variables wrt w + J%data(:, 3, i) = (/-u, u, -1.d0/ep - u/) end do ! stationary boundary conditions - J%data(:,:,1) = 0.d0 - J%data(:,:,N) = 0.d0 + J%data(:, :, 1) = 0.d0 + J%data(:, :, N) = 0.d0 ! return success ierr = 0 @@ -280,13 +280,13 @@ program main real(c_double) :: pi, tcur(1), dTout, tout type(c_ptr) :: sunctx ! sundials context for the simulation - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunls ! sundials linear solver type(c_ptr) :: arkode_mem ! ARKODE memory ! solution vector, N and Nvar are set in the ode_mod module - real(c_double) :: y(Nvar,N) + real(c_double) :: y(Nvar, N) !======= Internals ============ @@ -295,93 +295,93 @@ program main print *, "1D Brusselator PDE test problem (F2003 with custom data structures):" print '(a,i5,a,i5)', " N = ", N, ", NEQ = ", neq print '(3(a,es9.2))', " problem parameters: a = ", a, ", b = ", b, ", ep = ", ep - print '(3(a,es10.3))', " diffusion coefficients: du = ",du,", dv = ",dv,", dw = ",dw - print '(2(a,es8.1))', " reltol = ",reltol,", abstol = ",abstol + print '(3(a,es10.3))', " diffusion coefficients: du = ", du, ", dv = ", dv, ", dw = ", dw + print '(2(a,es8.1))', " reltol = ", reltol, ", abstol = ", abstol ! create the SUNDIALS context for the simulation ierr = FSUNContext_Create(SUN_COMM_NULL, sunctx) if (ierr /= 0) then - write(*,*) 'Error in FSUNContext_Create' + write (*, *) 'Error in FSUNContext_Create' stop 1 end if ! initialize SUNDIALS solution vector sunvec_y => FN_VMake_Fortran(Nvar, N, y, sunctx) if (.not. associated(sunvec_y)) then - write(*,*) 'ERROR: sunvec = NULL' + write (*, *) 'ERROR: sunvec = NULL' stop 1 end if ! Set initial conditions into y pi = 4.d0*datan(1.d0) - do i = 1,N - y(1,i) = a + 0.1d0*sin(pi*i*dx) ! u - y(2,i) = b/a + 0.1d0*sin(pi*i*dx) ! v - y(3,i) = b + 0.1d0*sin(pi*i*dx) ! w + do i = 1, N + y(1, i) = a + 0.1d0*sin(pi*i*dx) ! u + y(2, i) = b/a + 0.1d0*sin(pi*i*dx) ! v + y(3, i) = b + 0.1d0*sin(pi*i*dx) ! w end do ! create ARKStep memory arkode_mem = FARKStepCreate(c_funloc(RhsExplicit), c_funloc(RhsImplicit), T0, sunvec_y, sunctx) if (.not. c_associated(arkode_mem)) then - print *,'ERROR: arkode_mem = NULL' - stop 1 + print *, 'ERROR: arkode_mem = NULL' + stop 1 end if ! set routines ierr = FARKodeSStolerances(arkode_mem, reltol, abstol) if (ierr /= 0) then - write(*,*) 'Error in FARKodeSStolerances' + write (*, *) 'Error in FARKodeSStolerances' stop 1 end if ! initialize custom matrix data structure and solver; attach to ARKODE sunmat_A => FSUNMatNew_Fortran(Nvar, N, sunctx) if (.not. associated(sunmat_A)) then - print *,'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if sunls => FSUNLinSolNew_Fortran(Nvar, N, sunctx) if (.not. associated(sunls)) then - print *,'ERROR: sunls = NULL' - stop 1 + print *, 'ERROR: sunls = NULL' + stop 1 end if ! Attach matrix, linear solver, and Jacobian routine to linear solver interface ierr = FARKodeSetLinearSolver(arkode_mem, sunls, sunmat_A) if (ierr /= 0) then - write(*,*) 'Error in FARKodeSetLinearSolver' + write (*, *) 'Error in FARKodeSetLinearSolver' stop 1 end if ierr = FARKodeSetJacFn(arkode_mem, c_funloc(JacFn)) if (ierr /= 0) then - write(*,*) 'Error in FARKodeSetJacFn' + write (*, *) 'Error in FARKodeSetJacFn' stop 1 end if ! main time-stepping loop: calls FARKodeEvolve to perform the integration, then ! prints results. Stops when the final time has been reached tcur(1) = T0 - dTout = (Tf-T0)/Nt - tout = T0+dTout + dTout = (Tf - T0)/Nt + tout = T0 + dTout print *, " t ||u||_rms ||v||_rms ||w||_rms" print *, " ----------------------------------------------" - do iout = 1,Nt + do iout = 1, Nt - ! call integrator - ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) - if (ierr /= 0) then - write(*,*) 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' - stop 1 - endif + ! call integrator + ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) + if (ierr /= 0) then + write (*, *) 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' + stop 1 + end if - ! access/print solution statistics - print '(4(2x,f10.6))', tcur(1), dsqrt(sum(y(1,:)**2)/N), & - dsqrt(sum(y(2,:)**2)/N), dsqrt(sum(y(3,:)**2)/N) + ! access/print solution statistics + print '(4(2x,f10.6))', tcur(1), dsqrt(sum(y(1, :)**2)/N), & + dsqrt(sum(y(2, :)**2)/N), dsqrt(sum(y(3, :)**2)/N) - ! update output time - tout = min(tout + dTout, Tf) + ! update output time + tout = min(tout + dTout, Tf) end do print *, " ----------------------------------------------" @@ -398,7 +398,6 @@ program main end program main - ! ---------------------------------------------------------------- ! ARKStepStats ! @@ -445,14 +444,14 @@ subroutine ARKStepStats(arkode_mem) print *, ' ' print *, 'Final Solver Statistics:' - print '(4x,2(A,i9),A)' ,'Internal solver steps = ',nsteps(1),', (attempted = ',nst_a(1),')' - print '(4x,2(A,i9))' ,'Total RHS evals: Fe = ',nfe(1),', Fi = ',nfi(1) - print '(4x,A,i9)' ,'Total linear solver setups =',nlinsetups(1) - print '(4x,A,i9)' ,'Total RHS evals for setting up the linear system =',nfeLS(1) - print '(4x,A,i9)' ,'Total number of Jacobian evaluations =',nje(1) - print '(4x,A,i9)' ,'Total number of Newton iterations =',nniters(1) - print '(4x,A,i9)' ,'Total number of nonlinear solver convergence failures =',nncfails(1) - print '(4x,A,i9)' ,'Total number of error test failures =',netfails(1) + print '(4x,2(A,i9),A)', 'Internal solver steps = ', nsteps(1), ', (attempted = ', nst_a(1), ')' + print '(4x,2(A,i9))', 'Total RHS evals: Fe = ', nfe(1), ', Fi = ', nfi(1) + print '(4x,A,i9)', 'Total linear solver setups =', nlinsetups(1) + print '(4x,A,i9)', 'Total RHS evals for setting up the linear system =', nfeLS(1) + print '(4x,A,i9)', 'Total number of Jacobian evaluations =', nje(1) + print '(4x,A,i9)', 'Total number of Newton iterations =', nniters(1) + print '(4x,A,i9)', 'Total number of nonlinear solver convergence failures =', nncfails(1) + print '(4x,A,i9)', 'Total number of error test failures =', netfails(1) print *, ' ' return diff --git a/examples/arkode/F2003_custom/fnvector_complex_mod.f90 b/examples/arkode/F2003_custom/fnvector_complex_mod.f90 index e762a3858d..d6d1c0f504 100644 --- a/examples/arkode/F2003_custom/fnvector_complex_mod.f90 +++ b/examples/arkode/F2003_custom/fnvector_complex_mod.f90 @@ -35,18 +35,18 @@ module fnvector_complex_mod function FN_VNew_Complex(n, sunctx) result(sunvec_y) implicit none - integer(c_int64_t), value :: n - type(c_ptr), value :: sunctx - type(N_Vector), pointer :: sunvec_y + integer(c_int64_t), value :: n + type(c_ptr), value :: sunctx + type(N_Vector), pointer :: sunvec_y type(N_Vector_Ops), pointer :: ops - type(FVec), pointer :: content + type(FVec), pointer :: content ! allocate output N_Vector structure sunvec_y => FN_VNewEmpty(sunctx) ! allocate and fill content structure - allocate(content) - allocate(content%data(n)) + allocate (content) + allocate (content%data(n)) content%own_data = .true. content%len = n @@ -55,31 +55,31 @@ function FN_VNew_Complex(n, sunctx) result(sunvec_y) ! access the N_Vector ops structure, and set internal function pointers call c_f_pointer(sunvec_y%ops, ops) - ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Complex) - ops%nvdestroy = c_funloc(FN_VDestroy_Complex) - ops%nvgetlength = c_funloc(FN_VGetLength_Complex) - ops%nvconst = c_funloc(FN_VConst_Complex) - ops%nvclone = c_funloc(FN_VClone_Complex) - ops%nvspace = c_funloc(FN_VSpace_Complex) - ops%nvlinearsum = c_funloc(FN_VLinearSum_Complex) - ops%nvprod = c_funloc(FN_VProd_Complex) - ops%nvdiv = c_funloc(FN_VDiv_Complex) - ops%nvscale = c_funloc(FN_VScale_Complex) - ops%nvabs = c_funloc(FN_VAbs_Complex) - ops%nvinv = c_funloc(FN_VInv_Complex) - ops%nvaddconst = c_funloc(FN_VAddConst_Complex) - ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Complex) - ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Complex) - ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Complex) - ops%nvmin = c_funloc(FN_VMin_Complex) - ops%nvwl2norm = c_funloc(FN_VWL2Norm_Complex) - ops%nvl1norm = c_funloc(FN_VL1Norm_Complex) - ops%nvinvtest = c_funloc(FN_VInvTest_Complex) - ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Complex) - ops%nvminlocal = c_funloc(FN_VMin_Complex) - ops%nvl1normlocal = c_funloc(FN_VL1Norm_Complex) - ops%nvinvtestlocal = c_funloc(FN_VInvTest_Complex) - ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Complex) + ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Complex) + ops%nvdestroy = c_funloc(FN_VDestroy_Complex) + ops%nvgetlength = c_funloc(FN_VGetLength_Complex) + ops%nvconst = c_funloc(FN_VConst_Complex) + ops%nvclone = c_funloc(FN_VClone_Complex) + ops%nvspace = c_funloc(FN_VSpace_Complex) + ops%nvlinearsum = c_funloc(FN_VLinearSum_Complex) + ops%nvprod = c_funloc(FN_VProd_Complex) + ops%nvdiv = c_funloc(FN_VDiv_Complex) + ops%nvscale = c_funloc(FN_VScale_Complex) + ops%nvabs = c_funloc(FN_VAbs_Complex) + ops%nvinv = c_funloc(FN_VInv_Complex) + ops%nvaddconst = c_funloc(FN_VAddConst_Complex) + ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Complex) + ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Complex) + ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Complex) + ops%nvmin = c_funloc(FN_VMin_Complex) + ops%nvwl2norm = c_funloc(FN_VWL2Norm_Complex) + ops%nvl1norm = c_funloc(FN_VL1Norm_Complex) + ops%nvinvtest = c_funloc(FN_VInvTest_Complex) + ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Complex) + ops%nvminlocal = c_funloc(FN_VMin_Complex) + ops%nvl1normlocal = c_funloc(FN_VL1Norm_Complex) + ops%nvinvtestlocal = c_funloc(FN_VInvTest_Complex) + ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Complex) ops%nvwsqrsummasklocal = c_funloc(FN_VWSqrSumMask_Complex) end function FN_VNew_Complex @@ -88,18 +88,18 @@ end function FN_VNew_Complex function FN_VMake_Complex(n, data, sunctx) result(sunvec_y) implicit none - integer(c_int64_t), value :: n - type(c_ptr), value :: sunctx - type(N_Vector), pointer :: sunvec_y - type(N_Vector_Ops), pointer :: ops - type(FVec), pointer :: content + integer(c_int64_t), value :: n + type(c_ptr), value :: sunctx + type(N_Vector), pointer :: sunvec_y + type(N_Vector_Ops), pointer :: ops + type(FVec), pointer :: content complex(c_double_complex), target :: data(:) ! allocate output N_Vector structure sunvec_y => FN_VNewEmpty(sunctx) ! allocate and fill content structure - allocate(content) + allocate (content) content%own_data = .false. content%len = n content%data => data @@ -109,31 +109,31 @@ function FN_VMake_Complex(n, data, sunctx) result(sunvec_y) ! access the N_Vector ops structure, and set internal function pointers call c_f_pointer(sunvec_y%ops, ops) - ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Complex) - ops%nvdestroy = c_funloc(FN_VDestroy_Complex) - ops%nvgetlength = c_funloc(FN_VGetLength_Complex) - ops%nvconst = c_funloc(FN_VConst_Complex) - ops%nvclone = c_funloc(FN_VClone_Complex) - ops%nvspace = c_funloc(FN_VSpace_Complex) - ops%nvlinearsum = c_funloc(FN_VLinearSum_Complex) - ops%nvprod = c_funloc(FN_VProd_Complex) - ops%nvdiv = c_funloc(FN_VDiv_Complex) - ops%nvscale = c_funloc(FN_VScale_Complex) - ops%nvabs = c_funloc(FN_VAbs_Complex) - ops%nvinv = c_funloc(FN_VInv_Complex) - ops%nvaddconst = c_funloc(FN_VAddConst_Complex) - ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Complex) - ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Complex) - ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Complex) - ops%nvmin = c_funloc(FN_VMin_Complex) - ops%nvwl2norm = c_funloc(FN_VWL2Norm_Complex) - ops%nvl1norm = c_funloc(FN_VL1Norm_Complex) - ops%nvinvtest = c_funloc(FN_VInvTest_Complex) - ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Complex) - ops%nvminlocal = c_funloc(FN_VMin_Complex) - ops%nvl1normlocal = c_funloc(FN_VL1Norm_Complex) - ops%nvinvtestlocal = c_funloc(FN_VInvTest_Complex) - ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Complex) + ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Complex) + ops%nvdestroy = c_funloc(FN_VDestroy_Complex) + ops%nvgetlength = c_funloc(FN_VGetLength_Complex) + ops%nvconst = c_funloc(FN_VConst_Complex) + ops%nvclone = c_funloc(FN_VClone_Complex) + ops%nvspace = c_funloc(FN_VSpace_Complex) + ops%nvlinearsum = c_funloc(FN_VLinearSum_Complex) + ops%nvprod = c_funloc(FN_VProd_Complex) + ops%nvdiv = c_funloc(FN_VDiv_Complex) + ops%nvscale = c_funloc(FN_VScale_Complex) + ops%nvabs = c_funloc(FN_VAbs_Complex) + ops%nvinv = c_funloc(FN_VInv_Complex) + ops%nvaddconst = c_funloc(FN_VAddConst_Complex) + ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Complex) + ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Complex) + ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Complex) + ops%nvmin = c_funloc(FN_VMin_Complex) + ops%nvwl2norm = c_funloc(FN_VWL2Norm_Complex) + ops%nvl1norm = c_funloc(FN_VL1Norm_Complex) + ops%nvinvtest = c_funloc(FN_VInvTest_Complex) + ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Complex) + ops%nvminlocal = c_funloc(FN_VMin_Complex) + ops%nvl1normlocal = c_funloc(FN_VL1Norm_Complex) + ops%nvinvtestlocal = c_funloc(FN_VInvTest_Complex) + ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Complex) ops%nvwsqrsummasklocal = c_funloc(FN_VWSqrSumMask_Complex) end function FN_VMake_Complex @@ -169,16 +169,16 @@ subroutine FN_VDestroy_Complex(sunvec_y) bind(C) implicit none type(N_Vector), target :: sunvec_y - type(FVec), pointer :: y + type(FVec), pointer :: y ! access FVec structure y => FN_VGetFVec(sunvec_y) ! if vector owns the data, then deallocate - if (y%own_data) deallocate(y%data) + if (y%own_data) deallocate (y%data) ! deallocate the underlying Fortran object (the content) - deallocate(y) + deallocate (y) ! set N_Vector structure members to NULL and return sunvec_y%content = C_NULL_PTR @@ -192,11 +192,11 @@ end subroutine FN_VDestroy_Complex ! ---------------------------------------------------------------- integer(c_int64_t) function FN_VGetLength_Complex(sunvec_y) & - bind(C) result(length) + bind(C) result(length) implicit none type(N_Vector) :: sunvec_y - type(FVec), pointer :: y + type(FVec), pointer :: y y => FN_VGetFVec(sunvec_y) length = y%len @@ -210,7 +210,7 @@ subroutine FN_VConst_Complex(const, sunvec_y) bind(C) implicit none type(N_Vector) :: sunvec_y real(c_double), value :: const - type(FVec), pointer :: y + type(FVec), pointer :: y ! extract Fortran vector structure to work with y => FN_VGetFVec(sunvec_y) @@ -229,7 +229,7 @@ function FN_VClone_Complex(sunvec_x) result(y_ptr) bind(C) type(N_Vector), pointer :: sunvec_y type(c_ptr) :: y_ptr integer(c_int) :: retval - type(FVec), pointer :: x, y + type(FVec), pointer :: x, y ! extract Fortran vector structure to work with x => FN_VGetFVec(sunvec_x) @@ -241,8 +241,8 @@ function FN_VClone_Complex(sunvec_x) result(y_ptr) bind(C) retval = FN_VCopyOps(sunvec_x, sunvec_y) ! allocate and clone content structure - allocate(y) - allocate(y%data(x%len)) + allocate (y) + allocate (y%data(x%len)) y%own_data = .true. y%len = x%len @@ -276,7 +276,7 @@ end subroutine FN_VSpace_Complex ! ---------------------------------------------------------------- subroutine FN_VLinearSum_Complex(a, sunvec_x, b, sunvec_y, sunvec_z) & - bind(C) + bind(C) implicit none type(N_Vector) :: sunvec_x @@ -284,7 +284,7 @@ subroutine FN_VLinearSum_Complex(a, sunvec_x, b, sunvec_y, sunvec_z) & type(N_Vector) :: sunvec_z real(c_double), value :: a real(c_double), value :: b - type(FVec), pointer :: x, y, z + type(FVec), pointer :: x, y, z ! extract Fortran vector structures to work with x => FN_VGetFVec(sunvec_x) @@ -312,7 +312,7 @@ subroutine FN_VProd_Complex(sunvec_x, sunvec_y, sunvec_z) bind(C) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = x%data * y%data + z%data = x%data*y%data return end subroutine FN_VProd_Complex @@ -332,7 +332,7 @@ subroutine FN_VDiv_Complex(sunvec_x, sunvec_y, sunvec_z) bind(C) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = x%data / y%data + z%data = x%data/y%data return end subroutine FN_VDiv_Complex @@ -344,14 +344,14 @@ subroutine FN_VScale_Complex(c, sunvec_x, sunvec_z) bind(C) real(c_double), value :: c type(N_Vector) :: sunvec_x type(N_Vector) :: sunvec_z - type(FVec), pointer :: x, z + type(FVec), pointer :: x, z ! extract Fortran vector structures to work with x => FN_VGetFVec(sunvec_x) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = c * x%data + z%data = c*x%data return end subroutine FN_VScale_Complex @@ -387,7 +387,7 @@ subroutine FN_VInv_Complex(sunvec_x, sunvec_z) bind(C) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = 1.d0 / x%data + z%data = 1.d0/x%data return end subroutine FN_VInv_Complex @@ -399,7 +399,7 @@ subroutine FN_VAddConst_Complex(sunvec_x, b, sunvec_z) bind(C) type(N_Vector) :: sunvec_x real(c_double), value :: b type(N_Vector) :: sunvec_z - type(FVec), pointer :: x, z + type(FVec), pointer :: x, z ! extract Fortran vector structures to work with x => FN_VGetFVec(sunvec_x) @@ -413,7 +413,7 @@ end subroutine FN_VAddConst_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VMaxNorm_Complex(sunvec_x) & - result(maxnorm) bind(C) + result(maxnorm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -430,7 +430,7 @@ end function FN_VMaxNorm_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VWSqrSum_Complex(sunvec_x, sunvec_w) & - result(sqrsum) bind(C) + result(sqrsum) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -442,14 +442,14 @@ real(c_double) function FN_VWSqrSum_Complex(sunvec_x, sunvec_w) & w => FN_VGetFVec(sunvec_w) ! perform computation (via whole array ops) and return - sqrsum = sum(abs(x%data)**2 * abs(w%data)**2) + sqrsum = sum(abs(x%data)**2*abs(w%data)**2) return end function FN_VWSqrSum_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VWSqrSumMask_Complex(sunvec_x, sunvec_w, sunvec_id) & - result(sqrsum) bind(C) + result(sqrsum) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -465,10 +465,10 @@ real(c_double) function FN_VWSqrSumMask_Complex(sunvec_x, sunvec_w, sunvec_id) & ! perform computation and return sqrsum = 0.d0 - do i = 1,x%len - if (real(id%data(i)) > 0.d0) then - sqrsum = sqrsum + (abs(x%data(i)) * abs(w%data(i)))**2 - end if + do i = 1, x%len + if (real(id%data(i)) > 0.d0) then + sqrsum = sqrsum + (abs(x%data(i))*abs(w%data(i)))**2 + end if end do return @@ -476,7 +476,7 @@ end function FN_VWSqrSumMask_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VWRMSNorm_Complex(sunvec_x, sunvec_w) & - result(wrmsnorm) bind(C) + result(wrmsnorm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -487,14 +487,14 @@ real(c_double) function FN_VWRMSNorm_Complex(sunvec_x, sunvec_w) & x => FN_VGetFVec(sunvec_x) ! postprocess result from FN_VWSqrSum for result - wrmsnorm = dsqrt( FN_VWSqrSum_Complex(sunvec_x, sunvec_w) / x%len ) + wrmsnorm = dsqrt(FN_VWSqrSum_Complex(sunvec_x, sunvec_w)/x%len) return end function FN_VWRMSNorm_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VWRMSNormMask_Complex(sunvec_x, sunvec_w, sunvec_id) & - result(wrmsnorm) bind(C) + result(wrmsnorm) bind(C) implicit none type(N_Vector) :: sunvec_x type(N_Vector) :: sunvec_w @@ -505,14 +505,14 @@ real(c_double) function FN_VWRMSNormMask_Complex(sunvec_x, sunvec_w, sunvec_id) x => FN_VGetFVec(sunvec_x) ! postprocess result from FN_VWSqrSumMask for result - wrmsnorm = dsqrt( FN_VWSqrSumMask_Complex(sunvec_x, sunvec_w, sunvec_id) / x%len ) + wrmsnorm = dsqrt(FN_VWSqrSumMask_Complex(sunvec_x, sunvec_w, sunvec_id)/x%len) return end function FN_VWRMSNormMask_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VMin_Complex(sunvec_x) & - result(mnval) bind(C) + result(mnval) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -530,7 +530,7 @@ end function FN_VMin_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VWL2Norm_Complex(sunvec_x, sunvec_w) & - result(wl2norm) bind(C) + result(wl2norm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -548,7 +548,7 @@ end function FN_VWL2Norm_Complex ! ---------------------------------------------------------------- real(c_double) function FN_VL1Norm_Complex(sunvec_x) & - result(l1norm) bind(C) + result(l1norm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -565,7 +565,7 @@ end function FN_VL1Norm_Complex ! ---------------------------------------------------------------- integer(c_int) function FN_VInvTest_Complex(sunvec_x, sunvec_z) & - result(no_zero_found) bind(C) + result(no_zero_found) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -579,12 +579,12 @@ integer(c_int) function FN_VInvTest_Complex(sunvec_x, sunvec_z) & ! perform operation and return no_zero_found = 1 - do i = 1,x%len - if (x%data(i) == dcmplx(0.d0, 0.d0)) then - no_zero_found = 0 - else - z%data(i) = 1.d0 / x%data(i) - end if + do i = 1, x%len + if (x%data(i) == dcmplx(0.d0, 0.d0)) then + no_zero_found = 0 + else + z%data(i) = 1.d0/x%data(i) + end if end do return diff --git a/examples/arkode/F2003_custom/fnvector_fortran_mod.f90 b/examples/arkode/F2003_custom/fnvector_fortran_mod.f90 index 3264f75a5d..163885792b 100644 --- a/examples/arkode/F2003_custom/fnvector_fortran_mod.f90 +++ b/examples/arkode/F2003_custom/fnvector_fortran_mod.f90 @@ -27,7 +27,7 @@ module fnvector_fortran_mod logical :: own_data integer(c_int64_t) :: length1 integer(c_int64_t) :: length2 - real(c_double), pointer :: data(:,:) + real(c_double), pointer :: data(:, :) end type FVec ! ---------------------------------------------------------------- @@ -36,60 +36,60 @@ module fnvector_fortran_mod ! ---------------------------------------------------------------- function FN_VNew_Fortran(n1, n2, sunctx) result(sunvec_y) implicit none - integer(c_int64_t), value :: n1 - integer(c_int64_t), value :: n2 - type(c_ptr), value :: sunctx - type(N_Vector), pointer :: sunvec_y + integer(c_int64_t), value :: n1 + integer(c_int64_t), value :: n2 + type(c_ptr), value :: sunctx + type(N_Vector), pointer :: sunvec_y type(N_Vector_Ops), pointer :: ops - type(FVec), pointer :: content + type(FVec), pointer :: content ! allocate output N_Vector structure sunvec_y => FN_VNewEmpty(sunctx) ! allocate and fill content structure - allocate(content) - allocate(content%data(n1,n2)) + allocate (content) + allocate (content%data(n1, n2)) content%own_data = .true. - content%length1 = n1 - content%length2 = n2 + content%length1 = n1 + content%length2 = n2 ! attach the content structure to the output N_Vector sunvec_y%content = c_loc(content) ! access the N_Vector ops structure, and set internal function pointers call c_f_pointer(sunvec_y%ops, ops) - ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Fortran) - ops%nvdestroy = c_funloc(FN_VDestroy_Fortran) - ops%nvgetlength = c_funloc(FN_VGetLength_Fortran) - ops%nvconst = c_funloc(FN_VConst_Fortran) - ops%nvdotprod = c_funloc(FN_VDotProd_Fortran) - ops%nvclone = c_funloc(FN_VClone_Fortran) - ops%nvspace = c_funloc(FN_VSpace_Fortran) - ops%nvlinearsum = c_funloc(FN_VLinearSum_Fortran) - ops%nvprod = c_funloc(FN_VProd_Fortran) - ops%nvdiv = c_funloc(FN_VDiv_Fortran) - ops%nvscale = c_funloc(FN_VScale_Fortran) - ops%nvabs = c_funloc(FN_VAbs_Fortran) - ops%nvinv = c_funloc(FN_VInv_Fortran) - ops%nvaddconst = c_funloc(FN_VAddConst_Fortran) - ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Fortran) - ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Fortran) - ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Fortran) - ops%nvmin = c_funloc(FN_VMin_Fortran) - ops%nvwl2norm = c_funloc(FN_VWL2Norm_Fortran) - ops%nvl1norm = c_funloc(FN_VL1Norm_Fortran) - ops%nvcompare = c_funloc(FN_VCompare_Fortran) - ops%nvinvtest = c_funloc(FN_VInvTest_Fortran) - ops%nvconstrmask = c_funloc(FN_VConstrMask_Fortran) - ops%nvminquotient = c_funloc(FN_VMinQuotient_Fortran) - ops%nvdotprodlocal = c_funloc(FN_VDotProd_Fortran) - ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Fortran) - ops%nvminlocal = c_funloc(FN_VMin_Fortran) - ops%nvl1normlocal = c_funloc(FN_VL1Norm_Fortran) - ops%nvinvtestlocal = c_funloc(FN_VInvTest_Fortran) - ops%nvconstrmasklocal = c_funloc(FN_VConstrMask_Fortran) + ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Fortran) + ops%nvdestroy = c_funloc(FN_VDestroy_Fortran) + ops%nvgetlength = c_funloc(FN_VGetLength_Fortran) + ops%nvconst = c_funloc(FN_VConst_Fortran) + ops%nvdotprod = c_funloc(FN_VDotProd_Fortran) + ops%nvclone = c_funloc(FN_VClone_Fortran) + ops%nvspace = c_funloc(FN_VSpace_Fortran) + ops%nvlinearsum = c_funloc(FN_VLinearSum_Fortran) + ops%nvprod = c_funloc(FN_VProd_Fortran) + ops%nvdiv = c_funloc(FN_VDiv_Fortran) + ops%nvscale = c_funloc(FN_VScale_Fortran) + ops%nvabs = c_funloc(FN_VAbs_Fortran) + ops%nvinv = c_funloc(FN_VInv_Fortran) + ops%nvaddconst = c_funloc(FN_VAddConst_Fortran) + ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Fortran) + ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Fortran) + ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Fortran) + ops%nvmin = c_funloc(FN_VMin_Fortran) + ops%nvwl2norm = c_funloc(FN_VWL2Norm_Fortran) + ops%nvl1norm = c_funloc(FN_VL1Norm_Fortran) + ops%nvcompare = c_funloc(FN_VCompare_Fortran) + ops%nvinvtest = c_funloc(FN_VInvTest_Fortran) + ops%nvconstrmask = c_funloc(FN_VConstrMask_Fortran) + ops%nvminquotient = c_funloc(FN_VMinQuotient_Fortran) + ops%nvdotprodlocal = c_funloc(FN_VDotProd_Fortran) + ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Fortran) + ops%nvminlocal = c_funloc(FN_VMin_Fortran) + ops%nvl1normlocal = c_funloc(FN_VL1Norm_Fortran) + ops%nvinvtestlocal = c_funloc(FN_VInvTest_Fortran) + ops%nvconstrmasklocal = c_funloc(FN_VConstrMask_Fortran) ops%nvminquotientlocal = c_funloc(FN_VMinQuotient_Fortran) - ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Fortran) + ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Fortran) ops%nvwsqrsummasklocal = c_funloc(FN_VWSqrSumMask_Fortran) end function FN_VNew_Fortran @@ -97,61 +97,61 @@ end function FN_VNew_Fortran ! ---------------------------------------------------------------- function FN_VMake_Fortran(n1, n2, data, sunctx) result(sunvec_y) implicit none - integer(c_int64_t), value :: n1 - integer(c_int64_t), value :: n2 - type(c_ptr), value :: sunctx - type(N_Vector), pointer :: sunvec_y + integer(c_int64_t), value :: n1 + integer(c_int64_t), value :: n2 + type(c_ptr), value :: sunctx + type(N_Vector), pointer :: sunvec_y type(N_Vector_Ops), pointer :: ops - type(FVec), pointer :: content - real(c_double), target :: data(:,:) + type(FVec), pointer :: content + real(c_double), target :: data(:, :) ! allocate output N_Vector structure sunvec_y => FN_VNewEmpty(sunctx) ! allocate and fill content structure - allocate(content) + allocate (content) content%own_data = .false. - content%length1 = n1 - content%length2 = n2 - content%data => data + content%length1 = n1 + content%length2 = n2 + content%data => data ! attach the content structure to the output N_Vector sunvec_y%content = c_loc(content) ! access the N_Vector ops structure, and set internal function pointers call c_f_pointer(sunvec_y%ops, ops) - ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Fortran) - ops%nvdestroy = c_funloc(FN_VDestroy_Fortran) - ops%nvgetlength = c_funloc(FN_VGetLength_Fortran) - ops%nvconst = c_funloc(FN_VConst_Fortran) - ops%nvdotprod = c_funloc(FN_VDotProd_Fortran) - ops%nvclone = c_funloc(FN_VClone_Fortran) - ops%nvspace = c_funloc(FN_VSpace_Fortran) - ops%nvlinearsum = c_funloc(FN_VLinearSum_Fortran) - ops%nvprod = c_funloc(FN_VProd_Fortran) - ops%nvdiv = c_funloc(FN_VDiv_Fortran) - ops%nvscale = c_funloc(FN_VScale_Fortran) - ops%nvabs = c_funloc(FN_VAbs_Fortran) - ops%nvinv = c_funloc(FN_VInv_Fortran) - ops%nvaddconst = c_funloc(FN_VAddConst_Fortran) - ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Fortran) - ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Fortran) - ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Fortran) - ops%nvmin = c_funloc(FN_VMin_Fortran) - ops%nvwl2norm = c_funloc(FN_VWL2Norm_Fortran) - ops%nvl1norm = c_funloc(FN_VL1Norm_Fortran) - ops%nvcompare = c_funloc(FN_VCompare_Fortran) - ops%nvinvtest = c_funloc(FN_VInvTest_Fortran) - ops%nvconstrmask = c_funloc(FN_VConstrMask_Fortran) - ops%nvminquotient = c_funloc(FN_VMinQuotient_Fortran) - ops%nvdotprodlocal = c_funloc(FN_VDotProd_Fortran) - ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Fortran) - ops%nvminlocal = c_funloc(FN_VMin_Fortran) - ops%nvl1normlocal = c_funloc(FN_VL1Norm_Fortran) - ops%nvinvtestlocal = c_funloc(FN_VInvTest_Fortran) - ops%nvconstrmasklocal = c_funloc(FN_VConstrMask_Fortran) + ops%nvgetvectorid = c_funloc(FN_VGetVectorID_Fortran) + ops%nvdestroy = c_funloc(FN_VDestroy_Fortran) + ops%nvgetlength = c_funloc(FN_VGetLength_Fortran) + ops%nvconst = c_funloc(FN_VConst_Fortran) + ops%nvdotprod = c_funloc(FN_VDotProd_Fortran) + ops%nvclone = c_funloc(FN_VClone_Fortran) + ops%nvspace = c_funloc(FN_VSpace_Fortran) + ops%nvlinearsum = c_funloc(FN_VLinearSum_Fortran) + ops%nvprod = c_funloc(FN_VProd_Fortran) + ops%nvdiv = c_funloc(FN_VDiv_Fortran) + ops%nvscale = c_funloc(FN_VScale_Fortran) + ops%nvabs = c_funloc(FN_VAbs_Fortran) + ops%nvinv = c_funloc(FN_VInv_Fortran) + ops%nvaddconst = c_funloc(FN_VAddConst_Fortran) + ops%nvmaxnorm = c_funloc(FN_VMaxNorm_Fortran) + ops%nvwrmsnorm = c_funloc(FN_VWRMSNorm_Fortran) + ops%nvwrmsnormmask = c_funloc(FN_VWRMSNormMask_Fortran) + ops%nvmin = c_funloc(FN_VMin_Fortran) + ops%nvwl2norm = c_funloc(FN_VWL2Norm_Fortran) + ops%nvl1norm = c_funloc(FN_VL1Norm_Fortran) + ops%nvcompare = c_funloc(FN_VCompare_Fortran) + ops%nvinvtest = c_funloc(FN_VInvTest_Fortran) + ops%nvconstrmask = c_funloc(FN_VConstrMask_Fortran) + ops%nvminquotient = c_funloc(FN_VMinQuotient_Fortran) + ops%nvdotprodlocal = c_funloc(FN_VDotProd_Fortran) + ops%nvmaxnormlocal = c_funloc(FN_VMaxNorm_Fortran) + ops%nvminlocal = c_funloc(FN_VMin_Fortran) + ops%nvl1normlocal = c_funloc(FN_VL1Norm_Fortran) + ops%nvinvtestlocal = c_funloc(FN_VInvTest_Fortran) + ops%nvconstrmasklocal = c_funloc(FN_VConstrMask_Fortran) ops%nvminquotientlocal = c_funloc(FN_VMinQuotient_Fortran) - ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Fortran) + ops%nvwsqrsumlocal = c_funloc(FN_VWSqrSum_Fortran) ops%nvwsqrsummasklocal = c_funloc(FN_VWSqrSumMask_Fortran) end function FN_VMake_Fortran @@ -160,7 +160,7 @@ end function FN_VMake_Fortran function FN_VGetFVec(sunvec_x) result(x) implicit none type(N_Vector) :: sunvec_x - type(FVec), pointer :: x + type(FVec), pointer :: x ! extract Fortran matrix structure to output call c_f_pointer(sunvec_x%content, x) @@ -184,16 +184,16 @@ end function FN_VGetVectorID_Fortran subroutine FN_VDestroy_Fortran(sunvec_y) bind(C) implicit none type(N_Vector), target :: sunvec_y - type(FVec), pointer :: y + type(FVec), pointer :: y ! access FVec structure y => FN_VGetFVec(sunvec_y) ! if vector owns the data, then deallocate - if (y%own_data) deallocate(y%data) + if (y%own_data) deallocate (y%data) ! deallocate the underlying Fortran object (the content) - deallocate(y) + deallocate (y) ! set N_Vector structure members to NULL and return sunvec_y%content = C_NULL_PTR @@ -207,7 +207,7 @@ end subroutine FN_VDestroy_Fortran ! ---------------------------------------------------------------- integer(c_int64_t) function FN_VGetLength_Fortran(sunvec_y) & - bind(C) result(length) + bind(C) result(length) implicit none type(N_Vector) :: sunvec_y @@ -224,7 +224,7 @@ subroutine FN_VConst_Fortran(const, sunvec_y) bind(C) implicit none type(N_Vector) :: sunvec_y real(c_double), value :: const - type(FVec), pointer :: y + type(FVec), pointer :: y ! extract Fortran vector structure to work with y => FN_VGetFVec(sunvec_y) @@ -240,14 +240,14 @@ real(c_double) function FN_VDotProd_Fortran(sunvec_x, sunvec_y) & result(a) bind(C) implicit none type(N_Vector) :: sunvec_x, sunvec_y - type(FVec), pointer :: x, y + type(FVec), pointer :: x, y ! extract Fortran vector structures to work with x => FN_VGetFVec(sunvec_x) y => FN_VGetFVec(sunvec_y) ! do the dot product via Fortran intrinsics - a = sum(x%data * y%data) + a = sum(x%data*y%data) return end function FN_VDotProd_Fortran @@ -259,7 +259,7 @@ function FN_VClone_Fortran(sunvec_x) result(y_ptr) bind(C) type(N_Vector), pointer :: sunvec_y type(c_ptr) :: y_ptr integer(c_int) :: retval - type(FVec), pointer :: x, y + type(FVec), pointer :: x, y ! extract Fortran vector structure to work with x => FN_VGetFVec(sunvec_x) @@ -271,8 +271,8 @@ function FN_VClone_Fortran(sunvec_x) result(y_ptr) bind(C) retval = FN_VCopyOps(sunvec_x, sunvec_y) ! allocate and clone content structure - allocate(y) - allocate(y%data(x%length1,x%length2)) + allocate (y) + allocate (y%data(x%length1, x%length2)) y%own_data = .true. y%length1 = x%length1 y%length2 = x%length2 @@ -306,7 +306,7 @@ end subroutine FN_VSpace_Fortran ! ---------------------------------------------------------------- subroutine FN_VLinearSum_Fortran(a, sunvec_x, b, sunvec_y, sunvec_z) & - bind(C) + bind(C) implicit none type(N_Vector) :: sunvec_x @@ -314,7 +314,7 @@ subroutine FN_VLinearSum_Fortran(a, sunvec_x, b, sunvec_y, sunvec_z) & type(N_Vector) :: sunvec_z real(c_double), value :: a real(c_double), value :: b - type(FVec), pointer :: x, y, z + type(FVec), pointer :: x, y, z ! extract Fortran vector structures to work with x => FN_VGetFVec(sunvec_x) @@ -341,7 +341,7 @@ subroutine FN_VProd_Fortran(sunvec_x, sunvec_y, sunvec_z) bind(C) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = x%data * y%data + z%data = x%data*y%data return end subroutine FN_VProd_Fortran @@ -360,7 +360,7 @@ subroutine FN_VDiv_Fortran(sunvec_x, sunvec_y, sunvec_z) bind(C) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = x%data / y%data + z%data = x%data/y%data return end subroutine FN_VDiv_Fortran @@ -371,14 +371,14 @@ subroutine FN_VScale_Fortran(c, sunvec_x, sunvec_z) bind(C) real(c_double), value :: c type(N_Vector) :: sunvec_x type(N_Vector) :: sunvec_z - type(FVec), pointer :: x, z + type(FVec), pointer :: x, z ! extract Fortran vector structures to work with x => FN_VGetFVec(sunvec_x) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = c * x%data + z%data = c*x%data return end subroutine FN_VScale_Fortran @@ -412,7 +412,7 @@ subroutine FN_VInv_Fortran(sunvec_x, sunvec_z) bind(C) z => FN_VGetFVec(sunvec_z) ! perform computation (via whole array ops) and return - z%data = 1.d0 / x%data + z%data = 1.d0/x%data return end subroutine FN_VInv_Fortran @@ -423,7 +423,7 @@ subroutine FN_VAddConst_Fortran(sunvec_x, b, sunvec_z) bind(C) type(N_Vector) :: sunvec_x real(c_double), value :: b type(N_Vector) :: sunvec_z - type(FVec), pointer :: x, z + type(FVec), pointer :: x, z ! extract Fortran vector structures to work with x => FN_VGetFVec(sunvec_x) @@ -437,7 +437,7 @@ end subroutine FN_VAddConst_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VMaxNorm_Fortran(sunvec_x) & - result(maxnorm) bind(C) + result(maxnorm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -454,7 +454,7 @@ end function FN_VMaxNorm_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VWSqrSum_Fortran(sunvec_x, sunvec_w) & - result(sqrsum) bind(C) + result(sqrsum) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -466,14 +466,14 @@ real(c_double) function FN_VWSqrSum_Fortran(sunvec_x, sunvec_w) & w => FN_VGetFVec(sunvec_w) ! perform computation (via whole array ops) and return - sqrsum = sum(x%data * x%data * w%data * w%data) + sqrsum = sum(x%data*x%data*w%data*w%data) return end function FN_VWSqrSum_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VWSqrSumMask_Fortran(sunvec_x, sunvec_w, sunvec_id) & - result(sqrsum) bind(C) + result(sqrsum) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -489,12 +489,12 @@ real(c_double) function FN_VWSqrSumMask_Fortran(sunvec_x, sunvec_w, sunvec_id) & ! perform computation and return sqrsum = 0.d0 - do j = 1,x%length2 - do i = 1,x%length1 - if (id%data(i,j) > 0.d0) then - sqrsum = sqrsum + (x%data(i,j) * w%data(i,j))**2 - end if - end do + do j = 1, x%length2 + do i = 1, x%length1 + if (id%data(i, j) > 0.d0) then + sqrsum = sqrsum + (x%data(i, j)*w%data(i, j))**2 + end if + end do end do return @@ -502,7 +502,7 @@ end function FN_VWSqrSumMask_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VWRMSNorm_Fortran(sunvec_x, sunvec_w) & - result(wrmsnorm) bind(C) + result(wrmsnorm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -513,14 +513,14 @@ real(c_double) function FN_VWRMSNorm_Fortran(sunvec_x, sunvec_w) & x => FN_VGetFVec(sunvec_x) ! postprocess result from FN_VWSqrSum for result - wrmsnorm = dsqrt( FN_VWSqrSum_Fortran(sunvec_x, sunvec_w) / (x%length1 * x%length2) ) + wrmsnorm = dsqrt(FN_VWSqrSum_Fortran(sunvec_x, sunvec_w)/(x%length1*x%length2)) return end function FN_VWRMSNorm_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VWRMSNormMask_Fortran(sunvec_x, sunvec_w, sunvec_id) & - result(wrmsnorm) bind(C) + result(wrmsnorm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -532,14 +532,14 @@ real(c_double) function FN_VWRMSNormMask_Fortran(sunvec_x, sunvec_w, sunvec_id) x => FN_VGetFVec(sunvec_x) ! postprocess result from FN_VWSqrSumMask for result - wrmsnorm = dsqrt( FN_VWSqrSumMask_Fortran(sunvec_x, sunvec_w, sunvec_id) / (x%length1 * x%length2) ) + wrmsnorm = dsqrt(FN_VWSqrSumMask_Fortran(sunvec_x, sunvec_w, sunvec_id)/(x%length1*x%length2)) return end function FN_VWRMSNormMask_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VMin_Fortran(sunvec_x) & - result(mnval) bind(C) + result(mnval) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -556,7 +556,7 @@ end function FN_VMin_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VWL2Norm_Fortran(sunvec_x, sunvec_w) & - result(wl2norm) bind(C) + result(wl2norm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -574,7 +574,7 @@ end function FN_VWL2Norm_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VL1Norm_Fortran(sunvec_x) & - result(l1norm) bind(C) + result(l1norm) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -595,7 +595,7 @@ subroutine FN_VCompare_Fortran(c, sunvec_x, sunvec_z) bind(C) real(c_double), value :: c type(N_Vector) :: sunvec_x type(N_Vector) :: sunvec_z - type(FVec), pointer :: x, z + type(FVec), pointer :: x, z integer(c_int64_t) :: i, j ! extract Fortran vector structures to work with @@ -603,14 +603,14 @@ subroutine FN_VCompare_Fortran(c, sunvec_x, sunvec_z) bind(C) z => FN_VGetFVec(sunvec_z) ! perform operation and return - do j = 1,x%length2 - do i = 1,x%length1 - if (abs(x%data(i,j)) .ge. c) then - z%data(i,j) = 1.d0 - else - z%data(i,j) = 0.d0 - end if - end do + do j = 1, x%length2 + do i = 1, x%length1 + if (abs(x%data(i, j)) >= c) then + z%data(i, j) = 1.d0 + else + z%data(i, j) = 0.d0 + end if + end do end do return @@ -618,7 +618,7 @@ end subroutine FN_VCompare_Fortran ! ---------------------------------------------------------------- integer(c_int) function FN_VInvTest_Fortran(sunvec_x, sunvec_z) & - result(no_zero_found) bind(C) + result(no_zero_found) bind(C) implicit none type(N_Vector) :: sunvec_x @@ -632,14 +632,14 @@ integer(c_int) function FN_VInvTest_Fortran(sunvec_x, sunvec_z) & ! perform operation and return no_zero_found = 1 - do j = 1,x%length2 - do i = 1,x%length1 - if (x%data(i,j) == 0.d0) then - no_zero_found = 0 - else - z%data(i,j) = 1.d0 / x%data(i,j) - end if - end do + do j = 1, x%length2 + do i = 1, x%length1 + if (x%data(i, j) == 0.d0) then + no_zero_found = 0 + else + z%data(i, j) = 1.d0/x%data(i, j) + end if + end do end do return @@ -647,7 +647,7 @@ end function FN_VInvTest_Fortran ! ---------------------------------------------------------------- integer(c_int) function FN_VConstrMask_Fortran(sunvec_c, sunvec_x, sunvec_m) & - result(all_good) bind(C) + result(all_good) bind(C) implicit none type(N_Vector) :: sunvec_c @@ -664,21 +664,21 @@ integer(c_int) function FN_VConstrMask_Fortran(sunvec_c, sunvec_x, sunvec_m) & ! perform operation and return all_good = 1 - do j = 1,x%length2 - do i = 1,x%length1 - m%data(i,j) = 0.d0 - - ! continue if no constraints were set for this variable - if (c%data(i,j) == 0.d0) cycle - - ! check if a set constraint has been violated - test = ((dabs(c%data(i,j)) > 1.5d0 .and. x%data(i,j)*c%data(i,j) .le. 0.d0) .or. & - (dabs(c%data(i,j)) > 0.5d0 .and. x%data(i,j)*c%data(i,j) < 0.d0)) - if (test) then - all_good = 0 - m%data(i,j) = 1.d0 - end if - end do + do j = 1, x%length2 + do i = 1, x%length1 + m%data(i, j) = 0.d0 + + ! continue if no constraints were set for this variable + if (c%data(i, j) == 0.d0) cycle + + ! check if a set constraint has been violated + test = ((dabs(c%data(i, j)) > 1.5d0 .and. x%data(i, j)*c%data(i, j) <= 0.d0) .or. & + (dabs(c%data(i, j)) > 0.5d0 .and. x%data(i, j)*c%data(i, j) < 0.d0)) + if (test) then + all_good = 0 + m%data(i, j) = 1.d0 + end if + end do end do return @@ -686,7 +686,7 @@ end function FN_VConstrMask_Fortran ! ---------------------------------------------------------------- real(c_double) function FN_VMinQuotient_Fortran(sunvec_n, sunvec_d) & - result(minq) bind(C) + result(minq) bind(C) implicit none type(N_Vector) :: sunvec_n @@ -704,20 +704,20 @@ real(c_double) function FN_VMinQuotient_Fortran(sunvec_n, sunvec_d) & minq = 1.d307 ! perform operation and return - do j = 1,n%length2 - do i = 1,n%length1 - - ! skip locations with zero-valued denominator - if (d%data(i,j) == 0.d0) cycle - - ! store the first quotient value - if (notEvenOnce) then - minq = n%data(i,j)/d%data(i,j) - notEvenOnce = .false. - else - minq = min(minq, n%data(i,j)/d%data(i,j)) - end if - end do + do j = 1, n%length2 + do i = 1, n%length1 + + ! skip locations with zero-valued denominator + if (d%data(i, j) == 0.d0) cycle + + ! store the first quotient value + if (notEvenOnce) then + minq = n%data(i, j)/d%data(i, j) + notEvenOnce = .false. + else + minq = min(minq, n%data(i, j)/d%data(i, j)) + end if + end do end do return diff --git a/examples/arkode/F2003_custom/fsunlinsol_fortran_mod.f90 b/examples/arkode/F2003_custom/fsunlinsol_fortran_mod.f90 index 9da06d3ea9..f9ddcbe404 100644 --- a/examples/arkode/F2003_custom/fsunlinsol_fortran_mod.f90 +++ b/examples/arkode/F2003_custom/fsunlinsol_fortran_mod.f90 @@ -30,9 +30,9 @@ module fsunlinsol_fortran_mod ! ---------------------------------------------------------------- type, public :: FLinSol - integer(c_int64_t) :: Nvar - integer(c_int64_t) :: N - integer(c_int64_t), allocatable :: pivots(:,:) + integer(c_int64_t) :: Nvar + integer(c_int64_t) :: N + integer(c_int64_t), allocatable :: pivots(:, :) end type FLinSol ! ---------------------------------------------------------------- @@ -42,21 +42,21 @@ module fsunlinsol_fortran_mod function FSUNLinSolNew_Fortran(Nvar, N, sunctx) result(sunls_S) implicit none - integer(c_int64_t), value :: Nvar - integer(c_int64_t), value :: N - type(c_ptr), value :: sunctx - type(SUNLinearSolver), pointer :: sunls_S + integer(c_int64_t), value :: Nvar + integer(c_int64_t), value :: N + type(c_ptr), value :: sunctx + type(SUNLinearSolver), pointer :: sunls_S type(SUNLinearSolver_Ops), pointer :: ops - type(FLinSol), pointer :: content + type(FLinSol), pointer :: content ! allocate output SUNLinearSolver structure sunls_S => FSUNLinSolNewEmpty(sunctx) ! allocate and fill content structure - allocate(content) - allocate(content%pivots(Nvar,N)) + allocate (content) + allocate (content%pivots(Nvar, N)) content%Nvar = NVar - content%N = N + content%N = N ! attach the content structure to the output SUNMatrix sunls_S%content = c_loc(content) @@ -64,10 +64,10 @@ function FSUNLinSolNew_Fortran(Nvar, N, sunctx) result(sunls_S) ! access the ops structure, and set internal function pointers call c_f_pointer(sunls_S%ops, ops) ops%gettype = c_funloc(FSUNLinSolGetType_Fortran) - ops%setup = c_funloc(FSUNLinSolSetup_Fortran) - ops%solve = c_funloc(FSUNLinSolSolve_Fortran) - ops%space = c_funloc(FSUNLinSolSpace_Fortran) - ops%free = c_funloc(FSUNLinSolFree_Fortran) + ops%setup = c_funloc(FSUNLinSolSetup_Fortran) + ops%solve = c_funloc(FSUNLinSolSolve_Fortran) + ops%space = c_funloc(FSUNLinSolSpace_Fortran) + ops%free = c_funloc(FSUNLinSolFree_Fortran) end function FSUNLinSolNew_Fortran @@ -99,20 +99,20 @@ end function FSUNLinSolGetType_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNLinSolFree_Fortran(sunls_S) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none type(SUNLinearSolver), target :: sunls_S - type(FLinSol), pointer :: S + type(FLinSol), pointer :: S ! access FLinSol structure S => FSUNLinSolGetFLinSol(sunls_S) ! deallocate pivots - deallocate(S%pivots) + deallocate (S%pivots) ! deallocate the underlying Fortran object (the content) - deallocate(S) + deallocate (S) ! set SUNLinearSolver structure members to NULL and return sunls_S%content = C_NULL_PTR @@ -128,71 +128,71 @@ end function FSUNLinSolFree_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNLinSolSetup_Fortran(sunls_S, sunmat_A) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none type(SUNLinearSolver) :: sunls_S type(SUNMatrix) :: sunmat_A - type(FLinSol), pointer :: S - type(FMat), pointer :: AMat + type(FLinSol), pointer :: S + type(FMat), pointer :: AMat integer(c_int64_t) :: i, j, k, l real(c_double) :: temp - real(c_double), pointer :: A(:,:) + real(c_double), pointer :: A(:, :) ! extract Fortran structures to work with S => FSUNLinSolGetFLinSol(sunls_S) AMat => FSUNMatGetFMat(sunmat_A) ! perform LU factorization of each block on diagonal - do i = 1,S%N - - ! set 2D pointer to this diagonal block - A => AMat%data(:,:,i) + do i = 1, S%N - ! k-th elimination step number - do k = 1,S%Nvar + ! set 2D pointer to this diagonal block + A => AMat%data(:, :, i) - ! find l = pivot row number - l = k - do j = k+1,S%Nvar - if (dabs(A(j,k)) > dabs(A(l,k))) then - l = j - end if - end do - S%pivots(k,i) = l - - ! check for zero pivot element - if (A(l,k) == 0.d0) then - ierr = int(k, c_int) - return - end if + ! k-th elimination step number + do k = 1, S%Nvar - ! swap a(k,1:n) and a(l,1:n) if necessary - if ( l /= k ) then - do j = 1,S%Nvar - temp = A(l,j) - A(l,j) = A(k,j) - A(k,j) = temp - end do + ! find l = pivot row number + l = k + do j = k + 1, S%Nvar + if (dabs(A(j, k)) > dabs(A(l, k))) then + l = j end if - - ! Scale the elements below the diagonal in - ! column k by 1.0/a(k,k). After the above swap - ! a(k,k) holds the pivot element. This scaling - ! stores the pivot row multipliers a(i,k)/a(k,k) - ! in a(i,k), i=k+1, ..., m-1. - A(k+1:S%Nvar,k) = A(k+1:S%Nvar,k) / A(k,k) - - ! row_i = row_i - [a(i,k)/a(k,k)] row_k, i=k+1, ..., Nvar - ! row k is the pivot row after swapping with row l. - ! The computation is done one column at a time - do j = k+1,S%Nvar - if (A(k,j) /= 0.d0) then - A(k+1:S%Nvar,j) = A(k+1:S%Nvar,j) - A(k,j) * A(k+1:S%Nvar,k) - end if + end do + S%pivots(k, i) = l + + ! check for zero pivot element + if (A(l, k) == 0.d0) then + ierr = int(k, c_int) + return + end if + + ! swap a(k,1:n) and a(l,1:n) if necessary + if (l /= k) then + do j = 1, S%Nvar + temp = A(l, j) + A(l, j) = A(k, j) + A(k, j) = temp end do + end if + + ! Scale the elements below the diagonal in + ! column k by 1.0/a(k,k). After the above swap + ! a(k,k) holds the pivot element. This scaling + ! stores the pivot row multipliers a(i,k)/a(k,k) + ! in a(i,k), i=k+1, ..., m-1. + A(k + 1:S%Nvar, k) = A(k + 1:S%Nvar, k)/A(k, k) + + ! row_i = row_i - [a(i,k)/a(k,k)] row_k, i=k+1, ..., Nvar + ! row k is the pivot row after swapping with row l. + ! The computation is done one column at a time + do j = k + 1, S%Nvar + if (A(k, j) /= 0.d0) then + A(k + 1:S%Nvar, j) = A(k + 1:S%Nvar, j) - A(k, j)*A(k + 1:S%Nvar, k) + end if + end do - end do + end do end do ! return with success @@ -203,7 +203,7 @@ end function FSUNLinSolSetup_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNLinSolSolve_Fortran(sunls_S, sunmat_A, & - sunvec_x, sunvec_b, tol) result(ierr) bind(C) + sunvec_x, sunvec_b, tol) result(ierr) bind(C) implicit none type(SUNLinearSolver) :: sunls_S @@ -211,12 +211,12 @@ integer(c_int) function FSUNLinSolSolve_Fortran(sunls_S, sunmat_A, & type(N_Vector) :: sunvec_x type(N_Vector) :: sunvec_b real(c_double), value :: tol - type(FLinSol), pointer :: S - type(FMat), pointer :: AMat - type(FVec), pointer :: xvec, bvec + type(FLinSol), pointer :: S + type(FMat), pointer :: AMat + type(FVec), pointer :: xvec, bvec integer(c_int64_t) :: i, k, pk real(c_double) :: temp - real(c_double), pointer :: A(:,:), x(:) + real(c_double), pointer :: A(:, :), x(:) ! extract Fortran structures to work with S => FSUNLinSolGetFLinSol(sunls_S) @@ -225,36 +225,36 @@ integer(c_int) function FSUNLinSolSolve_Fortran(sunls_S, sunmat_A, & bvec => FN_VGetFVec(sunvec_b) ! copy b into x - xvec%data(:,:) = bvec%data(:,:) + xvec%data(:, :) = bvec%data(:, :) ! perform solve using LU-factored blocks on matrix diagonal - do i = 1,S%N - - ! set pointer to this block of overall linear system - A => AMat%data(:,:,i) - x => xvec%data(:,i) - - ! Permute x, based on pivot information in p - do k = 1,S%Nvar - pk = S%pivots(k,i) - if (pk /= k) then - temp = x(k) - x(k) = x(pk) - x(pk) = temp - end if - end do - - ! Solve Ly = x, store solution y in x - do k = 1,S%Nvar-1 - x(k+1:S%Nvar) = x(k+1:S%Nvar) - x(k)*A(k+1:S%Nvar,k) - end do - - ! Solve Ux = y (y is initially stored in x) - do k = S%Nvar,2,-1 - x(k) = x(k)/A(k,k) - x(1:k-1) = x(1:k-1) - A(1:k-1,k)*x(k) - end do - x(1) = x(1)/A(1,1) + do i = 1, S%N + + ! set pointer to this block of overall linear system + A => AMat%data(:, :, i) + x => xvec%data(:, i) + + ! Permute x, based on pivot information in p + do k = 1, S%Nvar + pk = S%pivots(k, i) + if (pk /= k) then + temp = x(k) + x(k) = x(pk) + x(pk) = temp + end if + end do + + ! Solve Ly = x, store solution y in x + do k = 1, S%Nvar - 1 + x(k + 1:S%Nvar) = x(k + 1:S%Nvar) - x(k)*A(k + 1:S%Nvar, k) + end do + + ! Solve Ux = y (y is initially stored in x) + do k = S%Nvar, 2, -1 + x(k) = x(k)/A(k, k) + x(1:k - 1) = x(1:k - 1) - A(1:k - 1, k)*x(k) + end do + x(1) = x(1)/A(1, 1) end do @@ -266,7 +266,7 @@ end function FSUNLinSolSolve_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNLinSolSpace_Fortran(sunls_S, lrw, liw) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none type(SUNLinearSolver) :: sunls_S diff --git a/examples/arkode/F2003_custom/fsunmatrix_fortran_mod.f90 b/examples/arkode/F2003_custom/fsunmatrix_fortran_mod.f90 index 7d6b397e99..ced4f4263b 100644 --- a/examples/arkode/F2003_custom/fsunmatrix_fortran_mod.f90 +++ b/examples/arkode/F2003_custom/fsunmatrix_fortran_mod.f90 @@ -32,7 +32,7 @@ module fsunmatrix_fortran_mod logical :: own_data integer(c_int64_t) :: Nvar integer(c_int64_t) :: N - real(c_double), pointer :: data(:,:,:) + real(c_double), pointer :: data(:, :, :) end type FMat ! ---------------------------------------------------------------- @@ -42,37 +42,37 @@ module fsunmatrix_fortran_mod function FSUNMatNew_Fortran(Nvar, N, sunctx) result(sunmat_A) implicit none - integer(c_int64_t), value :: Nvar - integer(c_int64_t), value :: N - type(c_ptr), value :: sunctx - type(SUNMatrix), pointer :: sunmat_A + integer(c_int64_t), value :: Nvar + integer(c_int64_t), value :: N + type(c_ptr), value :: sunctx + type(SUNMatrix), pointer :: sunmat_A type(SUNMatrix_Ops), pointer :: ops - type(FMat), pointer :: content + type(FMat), pointer :: content ! allocate output SUNMatrix structure sunmat_A => FSUNMatNewEmpty(sunctx) ! allocate and fill content structure - allocate(content) - allocate(content%data(Nvar,Nvar,N)) + allocate (content) + allocate (content%data(Nvar, Nvar, N)) content%own_data = .true. - content%Nvar = NVar - content%N = N + content%Nvar = NVar + content%N = N ! attach the content structure to the output SUNMatrix sunmat_A%content = c_loc(content) ! access the SUNMatrix ops structure, and set internal function pointers call c_f_pointer(sunmat_A%ops, ops) - ops%getid = c_funloc(FSUNMatGetID_Fortran) - ops%clone = c_funloc(FSUNMatClone_Fortran) - ops%destroy = c_funloc(FSUNMatDestroy_Fortran) - ops%zero = c_funloc(FSUNMatZero_Fortran) - ops%copy = c_funloc(FSUNMatCopy_Fortran) - ops%scaleadd = c_funloc(FSUNMatScaleAdd_Fortran) + ops%getid = c_funloc(FSUNMatGetID_Fortran) + ops%clone = c_funloc(FSUNMatClone_Fortran) + ops%destroy = c_funloc(FSUNMatDestroy_Fortran) + ops%zero = c_funloc(FSUNMatZero_Fortran) + ops%copy = c_funloc(FSUNMatCopy_Fortran) + ops%scaleadd = c_funloc(FSUNMatScaleAdd_Fortran) ops%scaleaddi = c_funloc(FSUNMatScaleAddI_Fortran) - ops%matvec = c_funloc(FSUNMatMatvec_Fortran) - ops%space = c_funloc(FSUNMatSpace_Fortran) + ops%matvec = c_funloc(FSUNMatMatvec_Fortran) + ops%space = c_funloc(FSUNMatSpace_Fortran) end function FSUNMatNew_Fortran @@ -110,7 +110,7 @@ function FSUNMatClone_Fortran(sunmat_A) result(B_ptr) bind(C) type(SUNMatrix), pointer :: sunmat_B type(c_ptr) :: B_ptr integer(c_int) :: retval - type(FMat), pointer :: A, B + type(FMat), pointer :: A, B ! extract Fortran matrix structure to work with A => FSUNMatGetFMat(sunmat_A) @@ -122,8 +122,8 @@ function FSUNMatClone_Fortran(sunmat_A) result(B_ptr) bind(C) retval = FSUNMatCopyOps(sunmat_A, sunmat_B) ! allocate and clone content structure - allocate(B) - allocate(B%data(A%Nvar,A%Nvar,A%N)) + allocate (B) + allocate (B%data(A%Nvar, A%Nvar, A%N)) B%own_data = .true. B%Nvar = A%Nvar B%N = A%N @@ -142,16 +142,16 @@ subroutine FSUNMatDestroy_Fortran(sunmat_A) bind(C) implicit none type(SUNMatrix), target :: sunmat_A - type(FMat), pointer :: A + type(FMat), pointer :: A ! access FMat structure A => FSUNMatGetFMat(sunmat_A) ! if matrix owns the data, then deallocate - if (A%own_data) deallocate(A%data) + if (A%own_data) deallocate (A%data) ! deallocate the underlying Fortran object (the content) - deallocate(A) + deallocate (A) ! set SUNMatrix structure members to NULL and return sunmat_A%content = C_NULL_PTR @@ -165,7 +165,7 @@ end subroutine FSUNMatDestroy_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNMatZero_Fortran(sunmat_A) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none type(SUNMatrix) :: sunmat_A @@ -175,7 +175,7 @@ integer(c_int) function FSUNMatZero_Fortran(sunmat_A) & A => FSUNMatGetFMat(sunmat_A) ! set all entries to zero (whole array operation) - A%data(:,:,:) = 0.d0 + A%data(:, :, :) = 0.d0 ! return with success ierr = 0 @@ -185,7 +185,7 @@ end function FSUNMatZero_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNMatCopy_Fortran(sunmat_A, sunmat_B) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none type(SUNMatrix) :: sunmat_A @@ -197,7 +197,7 @@ integer(c_int) function FSUNMatCopy_Fortran(sunmat_A, sunmat_B) & B => FSUNMatGetFMat(sunmat_B) ! copy all entries from A into B (whole array operation) - B%data(:,:,:) = A%data(:,:,:) + B%data(:, :, :) = A%data(:, :, :) ! return with success ierr = 0 @@ -207,20 +207,20 @@ end function FSUNMatCopy_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNMatScaleAdd_Fortran(c, sunmat_A, sunmat_B) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none real(c_double), value :: c type(SUNMatrix) :: sunmat_A type(SUNMatrix) :: sunmat_B - type(FMat), pointer :: A, B + type(FMat), pointer :: A, B ! extract Fortran matrix structures to work with A => FSUNMatGetFMat(sunmat_A) B => FSUNMatGetFMat(sunmat_B) ! A = c*A + B (whole array operation) - A%data(:,:,:) = c * A%data(:,:,:) + B%data(:,:,:) + A%data(:, :, :) = c*A%data(:, :, :) + B%data(:, :, :) ! return with success ierr = 0 @@ -230,7 +230,7 @@ end function FSUNMatScaleAdd_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNMatScaleAddI_Fortran(c, sunmat_A) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none real(c_double), value :: c @@ -242,13 +242,13 @@ integer(c_int) function FSUNMatScaleAddI_Fortran(c, sunmat_A) & A => FSUNMatGetFMat(sunmat_A) ! A = c*A + I - do k = 1,A%N - do j = 1,A%Nvar - do i = 1,A%Nvar - A%data(i,j,k) = c * A%data(i,j,k) - end do - A%data(j,j,k) = A%data(j,j,k) + 1.d0 - end do + do k = 1, A%N + do j = 1, A%Nvar + do i = 1, A%Nvar + A%data(i, j, k) = c*A%data(i, j, k) + end do + A%data(j, j, k) = A%data(j, j, k) + 1.d0 + end do end do ! return with success @@ -259,7 +259,7 @@ end function FSUNMatScaleAddI_Fortran ! ---------------------------------------------------------------- integer(c_int) function FSUNMatMatvec_Fortran(sunmat_A, sunvec_x, sunvec_y) & - result(ierr) bind(C) + result(ierr) bind(C) implicit none type(SUNMatrix) :: sunmat_A @@ -275,8 +275,8 @@ integer(c_int) function FSUNMatMatvec_Fortran(sunmat_A, sunvec_x, sunvec_y) & y => FN_VGetFVec(sunvec_y) ! y = A*x - do i = 1,A%N - y%data(:,i) = matmul(A%data(:,:,i), x%data(:,i)) + do i = 1, A%N + y%data(:, i) = matmul(A%data(:, :, i), x%data(:, i)) end do ! return with success diff --git a/examples/arkode/F2003_custom/test_fnvector_complex_mod.f90 b/examples/arkode/F2003_custom/test_fnvector_complex_mod.f90 index b9cec621a6..aa28a002ac 100644 --- a/examples/arkode/F2003_custom/test_fnvector_complex_mod.f90 +++ b/examples/arkode/F2003_custom/test_fnvector_complex_mod.f90 @@ -36,8 +36,8 @@ integer(c_int) function check_ans(val, tol, N, sunvec_x) result(failure) x => FN_VGetFVec(sunvec_x) failure = 0 - do i = 1,N - if (abs(x%data(i) - val) > tol) failure = 1 + do i = 1, N + if (abs(x%data(i) - val) > tol) failure = 1 end do end function check_ans @@ -76,74 +76,72 @@ program main ! create new vectors, using New, Make and Clone routines sU => FN_VMake_Complex(N, Udata, sunctx) if (.not. associated(sU)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if U => FN_VGetFVec(sU) sV => FN_VNew_Complex(N, sunctx) if (.not. associated(sV)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if V => FN_VGetFVec(sV) sW => FN_VNew_Complex(N, sunctx) if (.not. associated(sW)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if W => FN_VGetFVec(sW) sX => FN_VNew_Complex(N, sunctx) if (.not. associated(sX)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if X => FN_VGetFVec(sX) sY => FN_VNew_Complex(N, sunctx) if (.not. associated(sY)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if Y => FN_VGetFVec(sY) call c_f_pointer(FN_VClone_Complex(sU), sZ) if (.not. associated(sZ)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if Z => FN_VGetFVec(sZ) - ! check vector ID if (FN_VGetVectorID(sU) /= SUNDIALS_NVEC_CUSTOM) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VGetVectorID' - print *, ' Unrecognized vector type', FN_VGetVectorID(sU) + fails = fails + 1 + print *, '>>> FAILED test -- FN_VGetVectorID' + print *, ' Unrecognized vector type', FN_VGetVectorID(sU) else - print *, 'PASSED test -- FN_VGetVectorID' + print *, 'PASSED test -- FN_VGetVectorID' end if - ! check vector length if (FN_VGetLength(sV) /= N) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VGetLength' - print *, ' ', FN_VGetLength(sV), ' /= ', N + fails = fails + 1 + print *, '>>> FAILED test -- FN_VGetLength' + print *, ' ', FN_VGetLength(sV), ' /= ', N else - print *, 'PASSED test -- FN_VGetLength' + print *, 'PASSED test -- FN_VGetLength' end if ! test FN_VConst Udata = 0.d0 call FN_VConst(1.d0, sU) if (check_ans(dcmplx(1.d0, 0.d0), 1.d-14, N, sU) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VConst' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VConst' else - print *, 'PASSED test -- FN_VConst' + print *, 'PASSED test -- FN_VConst' end if ! test FN_VLinearSum @@ -151,60 +149,60 @@ program main Y%data = dcmplx(-2.d0, 2.d0) call FN_VLinearSum(1.d0, sX, 1.d0, sY, sY) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sY) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 1a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 1a' else - print *, 'PASSED test -- FN_VLinearSum Case 1a' + print *, 'PASSED test -- FN_VLinearSum Case 1a' end if X%data = dcmplx(1.d0, -1.d0) Y%data = dcmplx(2.d0, -2.d0) call FN_VLinearSum(-1.d0, sX, 1.d0, sY, sY) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sY) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 1b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 1b' else - print *, 'PASSED test -- FN_VLinearSum Case 1b' + print *, 'PASSED test -- FN_VLinearSum Case 1b' end if X%data = dcmplx(2.d0, -2.d0) Y%data = dcmplx(-2.d0, 2.d0) call FN_VLinearSum(0.5d0, sX, 1.d0, sY, sY) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sY) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 1c' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 1c' else - print *, 'PASSED test -- FN_VLinearSum Case 1c' + print *, 'PASSED test -- FN_VLinearSum Case 1c' end if X%data = dcmplx(2.d0, -2.d0) Y%data = dcmplx(-1.d0, 1.d0) call FN_VLinearSum(1.d0, sX, 1.d0, sY, sX) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 2a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 2a' else - print *, 'PASSED test -- FN_VLinearSum Case 2a' + print *, 'PASSED test -- FN_VLinearSum Case 2a' end if X%data = dcmplx(1.d0, -1.d0) Y%data = dcmplx(2.d0, -2.d0) call FN_VLinearSum(1.d0, sX, -1.d0, sY, sX) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 2b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 2b' else - print *, 'PASSED test -- FN_VLinearSum Case 2b' + print *, 'PASSED test -- FN_VLinearSum Case 2b' end if X%data = dcmplx(2.d0, -2.d0) Y%data = dcmplx(-0.5d0, 0.5d0) call FN_VLinearSum(1.d0, sX, 2.d0, sY, sX) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 2c' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 2c' else - print *, 'PASSED test -- FN_VLinearSum Case 2c' + print *, 'PASSED test -- FN_VLinearSum Case 2c' end if X%data = dcmplx(-2.d0, 2.d0) @@ -212,10 +210,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(1.d0, sX, 1.d0, sY, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 3' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 3' else - print *, 'PASSED test -- FN_VLinearSum Case 3' + print *, 'PASSED test -- FN_VLinearSum Case 3' end if X%data = dcmplx(2.d0, -2.d0) @@ -223,10 +221,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(1.d0, sX, -1.d0, sY, sZ) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 4a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 4a' else - print *, 'PASSED test -- FN_VLinearSum Case 4a' + print *, 'PASSED test -- FN_VLinearSum Case 4a' end if X%data = dcmplx(2.d0, -2.d0) @@ -234,10 +232,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(-1.d0, sX, 1.d0, sY, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 4b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 4b' else - print *, 'PASSED test -- FN_VLinearSum Case 4b' + print *, 'PASSED test -- FN_VLinearSum Case 4b' end if X%data = dcmplx(2.d0, -2.d0) @@ -245,10 +243,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(1.d0, sX, 2.d0, sY, sZ) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 5a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 5a' else - print *, 'PASSED test -- FN_VLinearSum Case 5a' + print *, 'PASSED test -- FN_VLinearSum Case 5a' end if X%data = dcmplx(0.5d0, -0.5d0) @@ -256,10 +254,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(2.d0, sX, 1.d0, sY, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 5b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 5b' else - print *, 'PASSED test -- FN_VLinearSum Case 5b' + print *, 'PASSED test -- FN_VLinearSum Case 5b' end if X%data = dcmplx(-2.d0, 2.d0) @@ -267,10 +265,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(-1.d0, sX, 2.d0, sY, sZ) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 6a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 6a' else - print *, 'PASSED test -- FN_VLinearSum Case 6a' + print *, 'PASSED test -- FN_VLinearSum Case 6a' end if X%data = dcmplx(0.5d0, -0.5d0) @@ -278,10 +276,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(2.d0, sX, -1.d0, sY, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 6b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 6b' else - print *, 'PASSED test -- FN_VLinearSum Case 6b' + print *, 'PASSED test -- FN_VLinearSum Case 6b' end if X%data = dcmplx(1.d0, -1.d0) @@ -289,10 +287,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(2.d0, sX, 2.d0, sY, sZ) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 7' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 7' else - print *, 'PASSED test -- FN_VLinearSum Case 7' + print *, 'PASSED test -- FN_VLinearSum Case 7' end if X%data = dcmplx(0.5d0, -0.5d0) @@ -300,10 +298,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(2.d0, sX, -2.d0, sY, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 8' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 8' else - print *, 'PASSED test -- FN_VLinearSum Case 8' + print *, 'PASSED test -- FN_VLinearSum Case 8' end if X%data = dcmplx(1.d0, -1.d0) @@ -311,10 +309,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VLinearSum(2.d0, sX, 0.5d0, sY, sZ) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 9' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 9' else - print *, 'PASSED test -- FN_VLinearSum Case 9' + print *, 'PASSED test -- FN_VLinearSum Case 9' end if ! test FN_VProd @@ -323,10 +321,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VProd(sX, sY, sZ) if (check_ans(dcmplx(-1.d0, 0.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VProd Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VProd Case 1' else - print *, 'PASSED test -- FN_VProd Case 1' + print *, 'PASSED test -- FN_VProd Case 1' end if X%data = dcmplx(0.d0, 0.5d0) @@ -334,10 +332,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VProd(sX, sY, sZ) if (check_ans(dcmplx(0.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VProd Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VProd Case 2' else - print *, 'PASSED test -- FN_VProd Case 2' + print *, 'PASSED test -- FN_VProd Case 2' end if X%data = dcmplx(1.d0, 2.d0) @@ -345,10 +343,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VProd(sX, sY, sZ) if (check_ans(dcmplx(5.d0, 0.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VProd Case 3' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VProd Case 3' else - print *, 'PASSED test -- FN_VProd Case 3' + print *, 'PASSED test -- FN_VProd Case 3' end if ! test FN_VDiv @@ -357,10 +355,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VDiv(sX, sY, sZ) if (check_ans(dcmplx(0.5d0, 0.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VDiv Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VDiv Case 1' else - print *, 'PASSED test -- FN_VDiv Case 1' + print *, 'PASSED test -- FN_VDiv Case 1' end if X%data = dcmplx(0.d0, 1.d0) @@ -368,10 +366,10 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VDiv(sX, sY, sZ) if (check_ans(dcmplx(0.d0, 0.5d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VDiv Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VDiv Case 2' else - print *, 'PASSED test -- FN_VDiv Case 2' + print *, 'PASSED test -- FN_VDiv Case 2' end if X%data = dcmplx(4.d0, 2.d0) @@ -379,50 +377,50 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VDiv(sX, sY, sZ) if (check_ans(dcmplx(1.d0, 3.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VDiv Case 3' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VDiv Case 3' else - print *, 'PASSED test -- FN_VDiv Case 3' + print *, 'PASSED test -- FN_VDiv Case 3' end if ! test FN_VScale X%data = dcmplx(0.5d0, -0.5d0) call FN_VScale(2.d0, sX, sX) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 1' else - print *, 'PASSED test -- FN_VScale Case 1' + print *, 'PASSED test -- FN_VScale Case 1' end if X%data = dcmplx(-1.d0, 1.d0) Z%data = dcmplx(0.d0, 0.d0) call FN_VScale(1.d0, sX, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 2' else - print *, 'PASSED test -- FN_VScale Case 2' + print *, 'PASSED test -- FN_VScale Case 2' end if X%data = dcmplx(-1.d0, 1.d0) Z%data = dcmplx(0.d0, 0.d0) call FN_VScale(-1.d0, sX, sZ) if (check_ans(dcmplx(1.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 3' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 3' else - print *, 'PASSED test -- FN_VScale Case 3' + print *, 'PASSED test -- FN_VScale Case 3' end if X%data = dcmplx(-0.5d0, 0.5d0) Z%data = dcmplx(0.d0, 0.d0) call FN_VScale(2.d0, sX, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 4' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 4' else - print *, 'PASSED test -- FN_VScale Case 4' + print *, 'PASSED test -- FN_VScale Case 4' end if ! test FN_VAbs @@ -430,30 +428,30 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VAbs(sX, sZ) if (check_ans(dcmplx(1.d0, 0.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VAbs Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VAbs Case 1' else - print *, 'PASSED test -- FN_VAbs Case 1' + print *, 'PASSED test -- FN_VAbs Case 1' end if X%data = dcmplx(1.d0, -0.d0) Z%data = dcmplx(0.d0, 0.d0) call FN_VAbs(sX, sZ) if (check_ans(dcmplx(1.d0, 0.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VAbs Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VAbs Case 2' else - print *, 'PASSED test -- FN_VAbs Case 2' + print *, 'PASSED test -- FN_VAbs Case 2' end if X%data = dcmplx(3.d0, -4.d0) Z%data = dcmplx(0.d0, 0.d0) call FN_VAbs(sX, sZ) if (check_ans(dcmplx(5.d0, 0.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VAbs Case 3' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VAbs Case 3' else - print *, 'PASSED test -- FN_VAbs Case 3' + print *, 'PASSED test -- FN_VAbs Case 3' end if ! test FN_VInv @@ -461,20 +459,20 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VInv(sX, sZ) if (check_ans(dcmplx(0.5d0, 0.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VInv Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VInv Case 1' else - print *, 'PASSED test -- FN_VInv Case 1' + print *, 'PASSED test -- FN_VInv Case 1' end if X%data = dcmplx(0.d0, 1.d0) Z%data = dcmplx(0.d0, 0.d0) call FN_VInv(sX, sZ) if (check_ans(dcmplx(0.d0, -1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VInv Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VInv Case 2' else - print *, 'PASSED test -- FN_VInv Case 2' + print *, 'PASSED test -- FN_VInv Case 2' end if ! test FN_VAddConst @@ -482,30 +480,30 @@ program main Z%data = dcmplx(0.d0, 0.d0) call FN_VAddConst(sX, -2.d0, sZ) if (check_ans(dcmplx(-1.d0, 1.d0), 1.d-14, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VAddConst' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VAddConst' else - print *, 'PASSED test -- FN_VAddConst' + print *, 'PASSED test -- FN_VAddConst' end if ! test FN_VMaxNorm X%data = dcmplx(-0.5d0, 0.d0) X%data(N) = dcmplx(0.d0, -2.d0) if (dabs(FN_VMaxNorm(sX) - 2.d0) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VMaxNorm (',FN_VMaxNorm(sX),' /= 2.d0)' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VMaxNorm (', FN_VMaxNorm(sX), ' /= 2.d0)' else - print *, 'PASSED test -- FN_VMaxNorm' + print *, 'PASSED test -- FN_VMaxNorm' end if ! test FN_VWrmsNorm X%data = dcmplx(-0.5d0, 0.d0) Y%data = dcmplx(0.5d0, 0.d0) - if (dabs(FN_VWrmsNorm(sX,sY) - 0.25d0) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWrmsNorm (',FN_VWrmsNorm(sX,sY),' /= 0.25d0)' + if (dabs(FN_VWrmsNorm(sX, sY) - 0.25d0) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWrmsNorm (', FN_VWrmsNorm(sX, sY), ' /= 0.25d0)' else - print *, 'PASSED test -- FN_VWrmsNorm' + print *, 'PASSED test -- FN_VWrmsNorm' end if ! test FN_VWrmsNormMask @@ -514,42 +512,42 @@ program main Z%data = dcmplx(1.d0, 0.d0) Z%data(N) = dcmplx(0.d0, 0.d0) fac = dsqrt(1.d0*(N - 1)/N)*0.25d0 - if (dabs(FN_VWrmsNormMask(sX,sY,sZ) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWrmsNormMask (',FN_VWrmsNormMask(sX,sY,sZ),' /= ',fac,')' + if (dabs(FN_VWrmsNormMask(sX, sY, sZ) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWrmsNormMask (', FN_VWrmsNormMask(sX, sY, sZ), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWrmsNormMask' + print *, 'PASSED test -- FN_VWrmsNormMask' end if ! test FN_VMin X%data = dcmplx(2.d0, 0.d0) X%data(N) = dcmplx(-2.d0, -3.d0) if (dabs(FN_VMin(sX) + 2.d0) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VMin (',FN_VMin(sX),' /= -2.d0)' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VMin (', FN_VMin(sX), ' /= -2.d0)' else - print *, 'PASSED test -- FN_VMin' + print *, 'PASSED test -- FN_VMin' end if ! test FN_VWL2Norm X%data = dcmplx(-0.5d0, 0.d0) Y%data = dcmplx(0.5d0, 0.d0) fac = dsqrt(1.d0*N)*0.25d0 - if (dabs(FN_VWL2Norm(sX,sY) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWL2Norm (',FN_VWL2Norm(sX,sY),' /= ',fac,')' + if (dabs(FN_VWL2Norm(sX, sY) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWL2Norm (', FN_VWL2Norm(sX, sY), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWL2Norm' + print *, 'PASSED test -- FN_VWL2Norm' end if ! test FN_VL1Norm X%data = dcmplx(0.d0, -1.d0) fac = 1.d0*N if (dabs(FN_VL1Norm(sX) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VL1Norm (',FN_VL1Norm(sX),' /= ',fac,')' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VL1Norm (', FN_VL1Norm(sX), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VL1Norm' + print *, 'PASSED test -- FN_VL1Norm' end if ! test FN_VInvTest @@ -557,55 +555,54 @@ program main Z%data = dcmplx(0.d0, 0.d0) failure = (FN_VInvTest(sX, sZ) == 0) if ((check_ans(dcmplx(2.d0, 0.d0), 1.d-14, N, sZ) /= 0) .or. failure) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VInvTest Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VInvTest Case 1' else - print *, 'PASSED test -- FN_VInvTest Case 1' + print *, 'PASSED test -- FN_VInvTest Case 1' end if failure = .false. Z%data = dcmplx(0.d0, 0.d0) - do i = 1,N - loc = mod(i-1, 2) - if (loc == 0) X%data(i) = dcmplx(0.d0, 0.d0) - if (loc == 1) X%data(i) = dcmplx(0.5d0, 0.d0) + do i = 1, N + loc = mod(i - 1, 2) + if (loc == 0) X%data(i) = dcmplx(0.d0, 0.d0) + if (loc == 1) X%data(i) = dcmplx(0.5d0, 0.d0) end do - if (FN_VInvTest(sX, sZ) == 1) failure = .true. - do i = 1,N - loc = mod(i-1, 2) - if ((loc == 0) .and. (Z%data(i) /= dcmplx(0.d0, 0.d0))) failure = .true. - if ((loc == 1) .and. (Z%data(i) /= dcmplx(2.d0, 0.d0))) failure = .true. + if (FN_VInvTest(sX, sZ) == 1) failure = .true. + do i = 1, N + loc = mod(i - 1, 2) + if ((loc == 0) .and. (Z%data(i) /= dcmplx(0.d0, 0.d0))) failure = .true. + if ((loc == 1) .and. (Z%data(i) /= dcmplx(2.d0, 0.d0))) failure = .true. end do if (failure) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VInvTest Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VInvTest Case 2' else - print *, 'PASSED test -- FN_VInvTest Case 2' + print *, 'PASSED test -- FN_VInvTest Case 2' end if ! test FN_VWSqrSumLocal X%data = dcmplx(-1.d0, 0.d0) Y%data = dcmplx(0.5d0, 0.d0) fac = 0.25d0*N - if (dabs(FN_VWSqrSumLocal(sX,sY) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWSqrSumLocal (',FN_VWSqrSumLocal(sX,sY),' /= ',fac,')' + if (dabs(FN_VWSqrSumLocal(sX, sY) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWSqrSumLocal (', FN_VWSqrSumLocal(sX, sY), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWSqrSumLocal' + print *, 'PASSED test -- FN_VWSqrSumLocal' end if - ! test FN_VWSqrSumMaskLocal X%data = dcmplx(-1.d0, 0.d0) Y%data = dcmplx(0.5d0, 0.d0) Z%data = dcmplx(1.d0, 0.d0) Z%data(N) = dcmplx(0.d0, 0.d0) - fac = 0.25d0*(N-1) - if (dabs(FN_VWSqrSumMaskLocal(sX,sY,sZ) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWSqrSumMaskLocal (',FN_VWSqrSumMaskLocal(sX,sY,sZ),' /= ',fac,')' + fac = 0.25d0*(N - 1) + if (dabs(FN_VWSqrSumMaskLocal(sX, sY, sZ) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWSqrSumMaskLocal (', FN_VWSqrSumMaskLocal(sX, sY, sZ), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWSqrSumMaskLocal' + print *, 'PASSED test -- FN_VWSqrSumMaskLocal' end if ! free vectors @@ -621,10 +618,10 @@ program main ! print results if (fails > 0) then - print '(a,i3,a)', 'FAIL: FNVector module failed ',fails,' tests' - stop 1 + print '(a,i3,a)', 'FAIL: FNVector module failed ', fails, ' tests' + stop 1 else - print *, 'SUCCESS: FNVector module passed all tests' + print *, 'SUCCESS: FNVector module passed all tests' end if print *, ' ' diff --git a/examples/arkode/F2003_custom/test_fnvector_fortran_mod.f90 b/examples/arkode/F2003_custom/test_fnvector_fortran_mod.f90 index ac6e69c9d6..0673d668ad 100644 --- a/examples/arkode/F2003_custom/test_fnvector_fortran_mod.f90 +++ b/examples/arkode/F2003_custom/test_fnvector_fortran_mod.f90 @@ -35,10 +35,10 @@ integer(c_int) function check_ans(val, tol, Nvar, N, sunvec_x) result(failure) x => FN_VGetFVec(sunvec_x) failure = 0 - do j = 1,N - do i = 1,Nvar - if (dabs(x%data(i,j) - val) > tol) failure = 1 - end do + do j = 1, N + do i = 1, Nvar + if (dabs(x%data(i, j) - val) > tol) failure = 1 + end do end do end function check_ans @@ -64,11 +64,10 @@ program main integer(c_int64_t), parameter :: Nvar = 10 type(N_Vector), pointer :: sU, sV, sW, sX, sY, sZ type(FVec), pointer :: U, V, W, X, Y, Z - real(c_double), allocatable :: Udata(:,:) + real(c_double), allocatable :: Udata(:, :) real(c_double) :: fac logical :: failure - !======= Internals ============ ! initialize failure total @@ -78,77 +77,75 @@ program main fails = FSUNContext_Create(SUN_COMM_NULL, sunctx) ! create new vectors, using New, Make and Clone routines - allocate(Udata(Nvar,N)) + allocate (Udata(Nvar, N)) sU => FN_VMake_Fortran(Nvar, N, Udata, sunctx) if (.not. associated(sU)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if U => FN_VGetFVec(sU) sV => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sV)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if V => FN_VGetFVec(sV) sW => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sW)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if W => FN_VGetFVec(sW) sX => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sX)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if X => FN_VGetFVec(sX) sY => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sY)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if Y => FN_VGetFVec(sY) call c_f_pointer(FN_VClone_Fortran(sU), sZ) if (.not. associated(sZ)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if Z => FN_VGetFVec(sZ) - ! check vector ID if (FN_VGetVectorID(sU) /= SUNDIALS_NVEC_CUSTOM) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VGetVectorID' - print *, ' Unrecognized vector type', FN_VGetVectorID(sU) + fails = fails + 1 + print *, '>>> FAILED test -- FN_VGetVectorID' + print *, ' Unrecognized vector type', FN_VGetVectorID(sU) else - print *, 'PASSED test -- FN_VGetVectorID' + print *, 'PASSED test -- FN_VGetVectorID' end if - ! check vector length if (FN_VGetLength(sV) /= (N*Nvar)) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VGetLength' - print *, ' ', FN_VGetLength(sV), ' /= ', N*Nvar + fails = fails + 1 + print *, '>>> FAILED test -- FN_VGetLength' + print *, ' ', FN_VGetLength(sV), ' /= ', N*Nvar else - print *, 'PASSED test -- FN_VGetLength' + print *, 'PASSED test -- FN_VGetLength' end if ! test FN_VConst Udata = 0.d0 call FN_VConst(1.d0, sU) if (check_ans(1.d0, 1.d-14, Nvar, N, sU) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VConst' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VConst' else - print *, 'PASSED test -- FN_VConst' + print *, 'PASSED test -- FN_VConst' end if ! test FN_VLinearSum @@ -156,60 +153,60 @@ program main call FN_VConst(-2.d0, sY) call FN_VLinearSum(1.d0, sX, 1.d0, sY, sY) if (check_ans(-1.d0, 1.d-14, Nvar, N, sY) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 1a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 1a' else - print *, 'PASSED test -- FN_VLinearSum Case 1a' + print *, 'PASSED test -- FN_VLinearSum Case 1a' end if call FN_VConst(1.d0, sX) call FN_VConst(2.d0, sY) call FN_VLinearSum(-1.d0, sX, 1.d0, sY, sY) if (check_ans(1.d0, 1.d-14, Nvar, N, sY) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 1b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 1b' else - print *, 'PASSED test -- FN_VLinearSum Case 1b' + print *, 'PASSED test -- FN_VLinearSum Case 1b' end if call FN_VConst(2.d0, sX) call FN_VConst(-2.d0, sY) call FN_VLinearSum(0.5d0, sX, 1.d0, sY, sY) if (check_ans(-1.d0, 1.d-14, Nvar, N, sY) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 1c' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 1c' else - print *, 'PASSED test -- FN_VLinearSum Case 1c' + print *, 'PASSED test -- FN_VLinearSum Case 1c' end if call FN_VConst(2.d0, sX) call FN_VConst(-1.d0, sY) call FN_VLinearSum(1.d0, sX, 1.d0, sY, sX) if (check_ans(1.d0, 1.d-14, Nvar, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 2a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 2a' else - print *, 'PASSED test -- FN_VLinearSum Case 2a' + print *, 'PASSED test -- FN_VLinearSum Case 2a' end if call FN_VConst(1.d0, sX) call FN_VConst(2.d0, sY) call FN_VLinearSum(1.d0, sX, -1.d0, sY, sX) if (check_ans(-1.d0, 1.d-14, Nvar, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 2b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 2b' else - print *, 'PASSED test -- FN_VLinearSum Case 2b' + print *, 'PASSED test -- FN_VLinearSum Case 2b' end if call FN_VConst(2.d0, sX) call FN_VConst(-0.5d0, sY) call FN_VLinearSum(1.d0, sX, 2.d0, sY, sX) if (check_ans(1.d0, 1.d-14, Nvar, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 2c' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 2c' else - print *, 'PASSED test -- FN_VLinearSum Case 2c' + print *, 'PASSED test -- FN_VLinearSum Case 2c' end if call FN_VConst(-2.d0, sX) @@ -217,10 +214,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(1.d0, sX, 1.d0, sY, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 3' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 3' else - print *, 'PASSED test -- FN_VLinearSum Case 3' + print *, 'PASSED test -- FN_VLinearSum Case 3' end if call FN_VConst(2.d0, sX) @@ -228,10 +225,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(1.d0, sX, -1.d0, sY, sZ) if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 4a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 4a' else - print *, 'PASSED test -- FN_VLinearSum Case 4a' + print *, 'PASSED test -- FN_VLinearSum Case 4a' end if call FN_VConst(2.d0, sX) @@ -239,10 +236,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(-1.d0, sX, 1.d0, sY, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 4b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 4b' else - print *, 'PASSED test -- FN_VLinearSum Case 4b' + print *, 'PASSED test -- FN_VLinearSum Case 4b' end if call FN_VConst(2.d0, sX) @@ -250,10 +247,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(1.d0, sX, 2.d0, sY, sZ) if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 5a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 5a' else - print *, 'PASSED test -- FN_VLinearSum Case 5a' + print *, 'PASSED test -- FN_VLinearSum Case 5a' end if call FN_VConst(0.5d0, sX) @@ -261,10 +258,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(2.d0, sX, 1.d0, sY, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 5b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 5b' else - print *, 'PASSED test -- FN_VLinearSum Case 5b' + print *, 'PASSED test -- FN_VLinearSum Case 5b' end if call FN_VConst(-2.d0, sX) @@ -272,10 +269,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(-1.d0, sX, 2.d0, sY, sZ) if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 6a' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 6a' else - print *, 'PASSED test -- FN_VLinearSum Case 6a' + print *, 'PASSED test -- FN_VLinearSum Case 6a' end if call FN_VConst(0.5d0, sX) @@ -283,10 +280,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(2.d0, sX, -1.d0, sY, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 6b' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 6b' else - print *, 'PASSED test -- FN_VLinearSum Case 6b' + print *, 'PASSED test -- FN_VLinearSum Case 6b' end if call FN_VConst(1.d0, sX) @@ -294,10 +291,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(2.d0, sX, 2.d0, sY, sZ) if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 7' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 7' else - print *, 'PASSED test -- FN_VLinearSum Case 7' + print *, 'PASSED test -- FN_VLinearSum Case 7' end if call FN_VConst(0.5d0, sX) @@ -305,10 +302,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(2.d0, sX, -2.d0, sY, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 8' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 8' else - print *, 'PASSED test -- FN_VLinearSum Case 8' + print *, 'PASSED test -- FN_VLinearSum Case 8' end if call FN_VConst(1.d0, sX) @@ -316,10 +313,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VLinearSum(2.d0, sX, 0.5d0, sY, sZ) if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VLinearSum Case 9' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VLinearSum Case 9' else - print *, 'PASSED test -- FN_VLinearSum Case 9' + print *, 'PASSED test -- FN_VLinearSum Case 9' end if ! test FN_VProd @@ -328,10 +325,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VProd(sX, sY, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VProd' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VProd' else - print *, 'PASSED test -- FN_VProd' + print *, 'PASSED test -- FN_VProd' end if ! test FN_VDiv @@ -340,50 +337,50 @@ program main call FN_VConst(0.d0, sZ) call FN_VDiv(sX, sY, sZ) if (check_ans(0.5d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VDiv' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VDiv' else - print *, 'PASSED test -- FN_VDiv' + print *, 'PASSED test -- FN_VDiv' end if ! test FN_VScale call FN_VConst(0.5d0, sX) call FN_VScale(2.d0, sX, sX) if (check_ans(1.d0, 1.d-14, Nvar, N, sX) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 1' else - print *, 'PASSED test -- FN_VScale Case 1' + print *, 'PASSED test -- FN_VScale Case 1' end if call FN_VConst(-1.d0, sX) call FN_VConst(0.d0, sZ) call FN_VScale(1.d0, sX, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 2' else - print *, 'PASSED test -- FN_VScale Case 2' + print *, 'PASSED test -- FN_VScale Case 2' end if call FN_VConst(-1.d0, sX) call FN_VConst(0.d0, sZ) call FN_VScale(-1.d0, sX, sZ) if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 3' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 3' else - print *, 'PASSED test -- FN_VScale Case 3' + print *, 'PASSED test -- FN_VScale Case 3' end if call FN_VConst(-0.5d0, sX) call FN_VConst(0.d0, sZ) call FN_VScale(2.d0, sX, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VScale Case 4' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VScale Case 4' else - print *, 'PASSED test -- FN_VScale Case 4' + print *, 'PASSED test -- FN_VScale Case 4' end if ! test FN_VAbs @@ -391,10 +388,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VAbs(sX, sZ) if (check_ans(1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VAbs' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VAbs' else - print *, 'PASSED test -- FN_VAbs' + print *, 'PASSED test -- FN_VAbs' end if ! test FN_VInv @@ -402,10 +399,10 @@ program main call FN_VConst(0.d0, sZ) call FN_VInv(sX, sZ) if (check_ans(0.5d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VInv' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VInv' else - print *, 'PASSED test -- FN_VInv' + print *, 'PASSED test -- FN_VInv' end if ! test FN_VAddConst @@ -413,111 +410,111 @@ program main call FN_VConst(0.d0, sZ) call FN_VAddConst(sX, -2.d0, sZ) if (check_ans(-1.d0, 1.d-14, Nvar, N, sZ) /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VAddConst' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VAddConst' else - print *, 'PASSED test -- FN_VAddConst' + print *, 'PASSED test -- FN_VAddConst' end if ! test FN_VDotProd call FN_VConst(2.d0, sX) call FN_VConst(0.5d0, sY) - if (dabs(FN_VDotProd(sX,sY) - (N*Nvar)) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VDotProd (',FN_VDotProd(sX,sY),' /= ',N*Nvar,')' + if (dabs(FN_VDotProd(sX, sY) - (N*Nvar)) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VDotProd (', FN_VDotProd(sX, sY), ' /= ', N*Nvar, ')' else - print *, 'PASSED test -- FN_VDotProd' + print *, 'PASSED test -- FN_VDotProd' end if ! test FN_VMaxNorm call FN_VConst(-0.5d0, sX) - X%data(Nvar,N) = -2.d0 + X%data(Nvar, N) = -2.d0 if (dabs(FN_VMaxNorm(sX) - 2.d0) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VMaxNorm (',FN_VMaxNorm(sX),' /= 2.d0)' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VMaxNorm (', FN_VMaxNorm(sX), ' /= 2.d0)' else - print *, 'PASSED test -- FN_VMaxNorm' + print *, 'PASSED test -- FN_VMaxNorm' end if ! test FN_VWrmsNorm call FN_VConst(-0.5d0, sX) call FN_VConst(0.5d0, sY) - if (dabs(FN_VWrmsNorm(sX,sY) - 0.25d0) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWrmsNorm (',FN_VWrmsNorm(sX,sY),' /= 0.25d0)' + if (dabs(FN_VWrmsNorm(sX, sY) - 0.25d0) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWrmsNorm (', FN_VWrmsNorm(sX, sY), ' /= 0.25d0)' else - print *, 'PASSED test -- FN_VWrmsNorm' + print *, 'PASSED test -- FN_VWrmsNorm' end if ! test FN_VWrmsNormMask call FN_VConst(-0.5d0, sX) call FN_VConst(0.5d0, sY) call FN_VConst(1.d0, sZ) - Z%data(Nvar,N) = 0.d0 + Z%data(Nvar, N) = 0.d0 fac = dsqrt(1.d0*(N*Nvar - 1)/(N*Nvar))*0.25d0 - if (dabs(FN_VWrmsNormMask(sX,sY,sZ) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWrmsNormMask (',FN_VWrmsNormMask(sX,sY,sZ),' /= ',fac,')' + if (dabs(FN_VWrmsNormMask(sX, sY, sZ) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWrmsNormMask (', FN_VWrmsNormMask(sX, sY, sZ), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWrmsNormMask' + print *, 'PASSED test -- FN_VWrmsNormMask' end if ! test FN_VMin call FN_VConst(2.d0, sX) - X%data(Nvar,N) = -2.d0 + X%data(Nvar, N) = -2.d0 if (dabs(FN_VMin(sX) + 2.d0) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VMin (',FN_VMin(sX),' /= -2.d0)' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VMin (', FN_VMin(sX), ' /= -2.d0)' else - print *, 'PASSED test -- FN_VMin' + print *, 'PASSED test -- FN_VMin' end if ! test FN_VWL2Norm call FN_VConst(-0.5d0, sX) call FN_VConst(0.5d0, sY) fac = dsqrt(1.d0*N*Nvar)*0.25d0 - if (dabs(FN_VWL2Norm(sX,sY) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWL2Norm (',FN_VWL2Norm(sX,sY),' /= ',fac,')' + if (dabs(FN_VWL2Norm(sX, sY) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWL2Norm (', FN_VWL2Norm(sX, sY), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWL2Norm' + print *, 'PASSED test -- FN_VWL2Norm' end if ! test FN_VL1Norm call FN_VConst(-1.d0, sX) fac = 1.d0*N*Nvar if (dabs(FN_VL1Norm(sX) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VL1Norm (',FN_VL1Norm(sX),' /= ',fac,')' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VL1Norm (', FN_VL1Norm(sX), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VL1Norm' + print *, 'PASSED test -- FN_VL1Norm' end if ! test FN_VCompare call FN_VConst(-1.d0, sZ) - do j = 1,N - do i = 1,Nvar - loc = mod((j-1)*Nvar + i - 1, 3_c_long) - if (loc == 0) X%data(i,j) = 0.d0 - if (loc == 1) X%data(i,j) = -1.d0 - if (loc == 2) X%data(i,j) = -2.d0 - end do + do j = 1, N + do i = 1, Nvar + loc = mod((j - 1)*Nvar + i - 1, 3_c_long) + if (loc == 0) X%data(i, j) = 0.d0 + if (loc == 1) X%data(i, j) = -1.d0 + if (loc == 2) X%data(i, j) = -2.d0 + end do end do call FN_VCompare(1.d0, sX, sZ) failure = .false. - do j = 1,N - do i = 1,Nvar - loc = mod((j-1)*Nvar + i - 1, 3_c_long) - if ((loc == 0) .and. (Z%data(i,j) /= 0.d0)) failure = .true. - if ((loc == 1) .and. (Z%data(i,j) /= 1.d0)) failure = .true. - if ((loc == 2) .and. (Z%data(i,j) /= 1.d0)) failure = .true. - end do + do j = 1, N + do i = 1, Nvar + loc = mod((j - 1)*Nvar + i - 1, 3_c_long) + if ((loc == 0) .and. (Z%data(i, j) /= 0.d0)) failure = .true. + if ((loc == 1) .and. (Z%data(i, j) /= 1.d0)) failure = .true. + if ((loc == 2) .and. (Z%data(i, j) /= 1.d0)) failure = .true. + end do end do if (failure) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VCompare' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VCompare' else - print *, 'PASSED test -- FN_VCompare' + print *, 'PASSED test -- FN_VCompare' end if ! test FN_VInvTest @@ -525,174 +522,173 @@ program main call FN_VConst(0.d0, sZ) failure = (FN_VInvTest(sX, sZ) == 0) if ((check_ans(2.d0, 1.d-14, Nvar, N, sZ) /= 0) .or. failure) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VInvTest Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VInvTest Case 1' else - print *, 'PASSED test -- FN_VInvTest Case 1' + print *, 'PASSED test -- FN_VInvTest Case 1' end if failure = .false. call FN_VConst(0.d0, sZ) - do j = 1,N - do i = 1,Nvar - loc = mod((j-1)*Nvar + i - 1, 2_c_long) - if (loc == 0) X%data(i,j) = 0.d0 - if (loc == 1) X%data(i,j) = 0.5d0 - end do + do j = 1, N + do i = 1, Nvar + loc = mod((j - 1)*Nvar + i - 1, 2_c_long) + if (loc == 0) X%data(i, j) = 0.d0 + if (loc == 1) X%data(i, j) = 0.5d0 + end do end do - if (FN_VInvTest(sX, sZ) == 1) failure = .true. - do j = 1,N - do i = 1,Nvar - loc = mod((j-1)*Nvar + i - 1, 2_c_long) - if ((loc == 0) .and. (Z%data(i,j) /= 0.d0)) failure = .true. - if ((loc == 1) .and. (Z%data(i,j) /= 2.d0)) failure = .true. - end do + if (FN_VInvTest(sX, sZ) == 1) failure = .true. + do j = 1, N + do i = 1, Nvar + loc = mod((j - 1)*Nvar + i - 1, 2_c_long) + if ((loc == 0) .and. (Z%data(i, j) /= 0.d0)) failure = .true. + if ((loc == 1) .and. (Z%data(i, j) /= 2.d0)) failure = .true. + end do end do if (failure) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VInvTest Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VInvTest Case 2' else - print *, 'PASSED test -- FN_VInvTest Case 2' + print *, 'PASSED test -- FN_VInvTest Case 2' end if ! test FN_VConstrMask call FN_VConst(-1.d0, sZ) - do j = 1,N - do i = 1,Nvar - loc = mod((j-1)*Nvar + i - 1, 7_c_long) - if (loc == 0) then ! y = -2, test for < 0 - Y%data(i,j) = -2.d0 - X%data(i,j) = -2.d0 - end if - if (loc == 1) then ! y = -1, test for <= 0 - Y%data(i,j) = -1.d0 - X%data(i,j) = -1.d0 - end if - if (loc == 2) then ! y = -1, test for == 0 - Y%data(i,j) = -1.d0 - X%data(i,j) = 0.d0 - end if - if (loc == 3) then ! y = 0, no test - Y%data(i,j) = 0.d0 - X%data(i,j) = 0.5d0 - end if - if (loc == 4) then ! y = 1, test for == 0 - Y%data(i,j) = 1.d0 - X%data(i,j) = 0.d0 - end if - if (loc == 5) then ! y = 1, test for >= 0 - Y%data(i,j) = 1.d0 - X%data(i,j) = 1.d0 - end if - if (loc == 6) then ! y = 2, test for > 0 - Y%data(i,j) = 2.d0 - X%data(i,j) = 2.d0 - end if - end do + do j = 1, N + do i = 1, Nvar + loc = mod((j - 1)*Nvar + i - 1, 7_c_long) + if (loc == 0) then ! y = -2, test for < 0 + Y%data(i, j) = -2.d0 + X%data(i, j) = -2.d0 + end if + if (loc == 1) then ! y = -1, test for <= 0 + Y%data(i, j) = -1.d0 + X%data(i, j) = -1.d0 + end if + if (loc == 2) then ! y = -1, test for == 0 + Y%data(i, j) = -1.d0 + X%data(i, j) = 0.d0 + end if + if (loc == 3) then ! y = 0, no test + Y%data(i, j) = 0.d0 + X%data(i, j) = 0.5d0 + end if + if (loc == 4) then ! y = 1, test for == 0 + Y%data(i, j) = 1.d0 + X%data(i, j) = 0.d0 + end if + if (loc == 5) then ! y = 1, test for >= 0 + Y%data(i, j) = 1.d0 + X%data(i, j) = 1.d0 + end if + if (loc == 6) then ! y = 2, test for > 0 + Y%data(i, j) = 2.d0 + X%data(i, j) = 2.d0 + end if + end do end do failure = .false. if (FN_VConstrMask(sY, sX, sZ) /= 1) then - failure = .true. + failure = .true. end if if ((check_ans(0.d0, 1.d-14, Nvar, N, sZ) /= 0) .or. failure) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VConstrMask Case 1' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VConstrMask Case 1' else - print *, 'PASSED test -- FN_VConstrMask Case 1' + print *, 'PASSED test -- FN_VConstrMask Case 1' end if call FN_VConst(-1.d0, sZ) - do j = 1,N - do i = 1,Nvar - loc = mod((j-1)*Nvar + i - 1, 5_c_long) - if (loc == 0) then ! y = -2, test for < 0 - Y%data(i,j) = -2.d0 - X%data(i,j) = 2.d0 - end if - if (loc == 1) then ! y = -1, test for <= 0 - Y%data(i,j) = -1.d0 - X%data(i,j) = 1.d0 - end if - if (loc == 2) then ! y = 0, no test - Y%data(i,j) = 0.d0 - X%data(i,j) = 0.5d0 - end if - if (loc == 3) then ! y = 1, test for >= 0 - Y%data(i,j) = 1.d0 - X%data(i,j) = -1.d0 - end if - if (loc == 4) then ! y = 2, test for > 0 - Y%data(i,j) = 2.d0 - X%data(i,j) = -2.d0 - end if - end do + do j = 1, N + do i = 1, Nvar + loc = mod((j - 1)*Nvar + i - 1, 5_c_long) + if (loc == 0) then ! y = -2, test for < 0 + Y%data(i, j) = -2.d0 + X%data(i, j) = 2.d0 + end if + if (loc == 1) then ! y = -1, test for <= 0 + Y%data(i, j) = -1.d0 + X%data(i, j) = 1.d0 + end if + if (loc == 2) then ! y = 0, no test + Y%data(i, j) = 0.d0 + X%data(i, j) = 0.5d0 + end if + if (loc == 3) then ! y = 1, test for >= 0 + Y%data(i, j) = 1.d0 + X%data(i, j) = -1.d0 + end if + if (loc == 4) then ! y = 2, test for > 0 + Y%data(i, j) = 2.d0 + X%data(i, j) = -2.d0 + end if + end do end do failure = .false. if (FN_VConstrMask(sY, sX, sZ) /= 0) then - failure = .true. - end if - do j = 1,N - do i = 1,Nvar - loc = mod((j-1)*Nvar + i - 1, 5_c_long) - if (loc == 2) then - if (Z%data(i,j) /= 0.d0) failure = .true. - else - if (Z%data(i,j) /= 1.d0) failure = .true. - end if - end do + failure = .true. + end if + do j = 1, N + do i = 1, Nvar + loc = mod((j - 1)*Nvar + i - 1, 5_c_long) + if (loc == 2) then + if (Z%data(i, j) /= 0.d0) failure = .true. + else + if (Z%data(i, j) /= 1.d0) failure = .true. + end if + end do end do if (failure) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VConstrMask Case 2' + fails = fails + 1 + print *, '>>> FAILED test -- FN_VConstrMask Case 2' else - print *, 'PASSED test -- FN_VConstrMask Case 2' + print *, 'PASSED test -- FN_VConstrMask Case 2' end if ! test FN_VMinQuotient call FN_VConst(2.d0, sX) call FN_VConst(2.d0, sY) - X%data(Nvar,N) = 0.5d0 + X%data(Nvar, N) = 0.5d0 fac = 0.25d0 - if (dabs(FN_VMinQuotient(sX,sY) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VMinQuotient Case 1' + if (dabs(FN_VMinQuotient(sX, sY) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VMinQuotient Case 1' else - print *, 'PASSED test -- FN_VMinQuotient Case 1' + print *, 'PASSED test -- FN_VMinQuotient Case 1' end if call FN_VConst(2.d0, sX) call FN_VConst(0.d0, sY) fac = 1.d307 - if (dabs(FN_VMinQuotient(sX,sY) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VMinQuotient Case 2' + if (dabs(FN_VMinQuotient(sX, sY) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VMinQuotient Case 2' else - print *, 'PASSED test -- FN_VMinQuotient Case 2' + print *, 'PASSED test -- FN_VMinQuotient Case 2' end if ! test FN_VWSqrSumLocal call FN_VConst(-1.d0, sX) call FN_VConst(0.5d0, sY) fac = 0.25d0*N*Nvar - if (dabs(FN_VWSqrSumLocal(sX,sY) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWSqrSumLocal (',FN_VWSqrSumLocal(sX,sY),' /= ',fac,')' + if (dabs(FN_VWSqrSumLocal(sX, sY) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWSqrSumLocal (', FN_VWSqrSumLocal(sX, sY), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWSqrSumLocal' + print *, 'PASSED test -- FN_VWSqrSumLocal' end if - ! test FN_VWSqrSumMaskLocal call FN_VConst(-1.d0, sX) call FN_VConst(0.5d0, sY) call FN_VConst(1.d0, sZ) - Z%data(Nvar,N) = 0.d0 - fac = 0.25d0*(N*Nvar-1) - if (dabs(FN_VWSqrSumMaskLocal(sX,sY,sZ) - fac) > 1.d-14) then - fails = fails + 1 - print *, '>>> FAILED test -- FN_VWSqrSumMaskLocal (',FN_VWSqrSumMaskLocal(sX,sY,sZ),' /= ',fac,')' + Z%data(Nvar, N) = 0.d0 + fac = 0.25d0*(N*Nvar - 1) + if (dabs(FN_VWSqrSumMaskLocal(sX, sY, sZ) - fac) > 1.d-14) then + fails = fails + 1 + print *, '>>> FAILED test -- FN_VWSqrSumMaskLocal (', FN_VWSqrSumMaskLocal(sX, sY, sZ), ' /= ', fac, ')' else - print *, 'PASSED test -- FN_VWSqrSumMaskLocal' + print *, 'PASSED test -- FN_VWSqrSumMaskLocal' end if ! free vectors @@ -704,17 +700,17 @@ program main call FN_VDestroy(sZ) ! Free vector data - deallocate(Udata) + deallocate (Udata) ! free SUNDIALS context fails = FSUNContext_Free(sunctx) ! print results if (fails > 0) then - print '(a,i3,a)', 'FAIL: FNVector module failed ',fails,' tests' - stop 1 + print '(a,i3,a)', 'FAIL: FNVector module failed ', fails, ' tests' + stop 1 else - print *, 'SUCCESS: FNVector module passed all tests' + print *, 'SUCCESS: FNVector module passed all tests' end if print *, ' ' diff --git a/examples/arkode/F2003_custom/test_fsunlinsol_fortran_mod.f90 b/examples/arkode/F2003_custom/test_fsunlinsol_fortran_mod.f90 index 15752897ce..dc1985d6ae 100644 --- a/examples/arkode/F2003_custom/test_fsunlinsol_fortran_mod.f90 +++ b/examples/arkode/F2003_custom/test_fsunlinsol_fortran_mod.f90 @@ -39,29 +39,29 @@ integer(c_int) function check_vector(sunvec_x, sunvec_y, tol, Nvar, N) result(fa x => FN_VGetFVec(sunvec_x) y => FN_VGetFVec(sunvec_y) failure = 0 - do j = 1,N - do i = 1,Nvar - if (dabs(x%data(i,j) - y%data(i,j)) > tol) then - failure = 1 - end if - end do + do j = 1, N + do i = 1, Nvar + if (dabs(x%data(i, j) - y%data(i, j)) > tol) then + failure = 1 + end if + end do end do if (failure == 1) then - print *, ' ' - print *, 'check_vector failure, differences:' - print *, ' blk idx x y diff' - print *, ' --------------------------------------------' - do j = 1,N - do i = 1,Nvar - if (dabs(x%data(i,j) - y%data(i,j)) > tol) then - print '(2x,2(i4,3x),3(es9.2,1x))', j, i, x%data(i,j), & - y%data(i,j), dabs(x%data(i,j) - y%data(i,j)) - end if - end do - end do - print *, ' --------------------------------------------' - print *, ' ' + print *, ' ' + print *, 'check_vector failure, differences:' + print *, ' blk idx x y diff' + print *, ' --------------------------------------------' + do j = 1, N + do i = 1, Nvar + if (dabs(x%data(i, j) - y%data(i, j)) > tol) then + print '(2x,2(i4,3x),3(es9.2,1x))', j, i, x%data(i, j), & + y%data(i, j), dabs(x%data(i, j) - y%data(i, j)) + end if + end do + end do + print *, ' --------------------------------------------' + print *, ' ' end if end function check_vector @@ -82,107 +82,105 @@ program main ! local variables type(c_ptr) :: sunctx integer(c_int) :: fails, retval, j, k - integer(c_int64_t), parameter :: N = 1000 - integer(c_int64_t), parameter :: Nvar = 50 - type(SUNMatrix), pointer :: sA - type(FMat), pointer :: A + integer(c_int64_t), parameter :: N = 1000 + integer(c_int64_t), parameter :: Nvar = 50 + type(SUNMatrix), pointer :: sA + type(FMat), pointer :: A type(SUNLinearSolver), pointer :: LS - type(FLinSol), pointer :: S - type(N_Vector), pointer :: sX, sY, sB - type(FVec), pointer :: X, B - + type(FLinSol), pointer :: S + type(N_Vector), pointer :: sX, sY, sB + type(FVec), pointer :: X, B !======= Internals ============ ! initialize failure total fails = 0 - ! create SUNDIALS context + ! create SUNDIALS context fails = FSUNContext_Create(SUN_COMM_NULL, sunctx) ! create new matrices and vectors sX => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sX)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if X => FN_VGetFVec(sX) sY => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sY)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sB => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sB)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if B => FN_VGetFVec(sB) sA => FSUNMatNew_Fortran(Nvar, N, sunctx) if (.not. associated(sA)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if A => FSUNMatGetFMat(sA) - ! fill A and X with uniformly-distributed random numbers in [0,1) call random_number(X%data) call random_number(A%data) ! update A to scale by 1/Nvar, and 1 to anti-diagonal of each diagonal block - do k = 1,N - A%data(:,:,k) = A%data(:,:,k)/Nvar - do j = 1,Nvar - A%data(Nvar-j+1,j,k) = A%data(Nvar-j+1,j,k) + 1.d0 - end do + do k = 1, N + A%data(:, :, k) = A%data(:, :, k)/Nvar + do j = 1, Nvar + A%data(Nvar - j + 1, j, k) = A%data(Nvar - j + 1, j, k) + 1.d0 + end do end do ! compute B = A*X retval = FSUNMatMatvec(sA, sX, sB) if (retval /= SUN_SUCCESS) then - print *, 'ERROR: FSUNMatMatvec fail' - stop 1 + print *, 'ERROR: FSUNMatMatvec fail' + stop 1 end if ! create custom linear solver LS => FSUNLinSolNew_Fortran(Nvar, N, sunctx) if (.not. associated(LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if S => FSUNLinSolGetFLinSol(LS) ! test SUNLinSolGetType if (FSUNLinSolGetType(LS) /= SUNLINEARSOLVER_DIRECT) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNLinSolGetType' - print *, ' Unrecognized vector type', FSUNLinSolGetType(LS) + fails = fails + 1 + print *, '>>> FAILED test -- FSUNLinSolGetType' + print *, ' Unrecognized vector type', FSUNLinSolGetType(LS) else - print *, 'PASSED test -- FSUNLinSolGetType' + print *, 'PASSED test -- FSUNLinSolGetType' end if ! test SUNLinSolSetup retval = FSUNLinSolSetup(LS, sA) if (retval /= SUN_SUCCESS) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNLinSolSetup' + fails = fails + 1 + print *, '>>> FAILED test -- FSUNLinSolSetup' else - print *, 'PASSED test -- FSUNLinSolSetup' + print *, 'PASSED test -- FSUNLinSolSetup' end if ! test SUNLinSolSolve call FN_VConst(0.d0, sY) retval = FSUNLinSolSolve(LS, sA, sY, sB, 1.d-9) - if ( (check_vector(sX, sY, 1.d-15*Nvar*Nvar, Nvar, N) /= 0) & - .or. (retval /= SUN_SUCCESS) ) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNLinSolSolve' + if ((check_vector(sX, sY, 1.d-15*Nvar*Nvar, Nvar, N) /= 0) & + .or. (retval /= SUN_SUCCESS)) then + fails = fails + 1 + print *, '>>> FAILED test -- FSUNLinSolSolve' else - print *, 'PASSED test -- FSUNLinSolSolve' + print *, 'PASSED test -- FSUNLinSolSolve' end if ! free solver, matrix and vectors @@ -192,10 +190,10 @@ program main call FN_VDestroy(sB) retval = FSUNLinSolFree(LS) if (retval /= 0) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNLinSolFree' + fails = fails + 1 + print *, '>>> FAILED test -- FSUNLinSolFree' else - print *, 'PASSED test -- FSUNLinSolFree' + print *, 'PASSED test -- FSUNLinSolFree' end if ! free SUNDIALS context @@ -203,10 +201,10 @@ program main ! print results if (fails > 0) then - print '(a,i3,a)', 'FAIL: FSUNLinSol module failed ',fails,' tests' - stop 1 + print '(a,i3,a)', 'FAIL: FSUNLinSol module failed ', fails, ' tests' + stop 1 else - print *, 'SUCCESS: FSUNLinSol module passed all tests' + print *, 'SUCCESS: FSUNLinSol module passed all tests' end if print *, ' ' diff --git a/examples/arkode/F2003_custom/test_fsunmatrix_fortran_mod.f90 b/examples/arkode/F2003_custom/test_fsunmatrix_fortran_mod.f90 index da5fe15966..190d1b9b61 100644 --- a/examples/arkode/F2003_custom/test_fsunmatrix_fortran_mod.f90 +++ b/examples/arkode/F2003_custom/test_fsunmatrix_fortran_mod.f90 @@ -38,12 +38,12 @@ integer(c_int) function check_matrix(sunmat_A, sunmat_B, tol, Nvar, N) result(fa A => FSUNMatGetFMat(sunmat_A) B => FSUNMatGetFMat(sunmat_B) failure = 0 - do k = 1,N - do j = 1,Nvar - do i = 1,Nvar - if (dabs(A%data(i,j,k) - B%data(i,j,k)) > tol) failure = 1 - end do - end do + do k = 1, N + do j = 1, Nvar + do i = 1, Nvar + if (dabs(A%data(i, j, k) - B%data(i, j, k)) > tol) failure = 1 + end do + end do end do end function check_matrix @@ -60,12 +60,12 @@ integer(c_int) function check_matrix_entry(sunmat_A, val, tol, Nvar, N) result(f A => FSUNMatGetFMat(sunmat_A) failure = 0 - do k = 1,N - do j = 1,Nvar - do i = 1,Nvar - if (dabs(A%data(i,j,k) - val) > tol) failure = 1 - end do - end do + do k = 1, N + do j = 1, Nvar + do i = 1, Nvar + if (dabs(A%data(i, j, k) - val) > tol) failure = 1 + end do + end do end do end function check_matrix_entry @@ -83,29 +83,29 @@ integer(c_int) function check_vector(sunvec_x, sunvec_y, tol, Nvar, N) result(fa x => FN_VGetFVec(sunvec_x) y => FN_VGetFVec(sunvec_y) failure = 0 - do j = 1,N - do i = 1,Nvar - if (dabs(x%data(i,j) - y%data(i,j)) > tol) then - failure = 1 - end if - end do + do j = 1, N + do i = 1, Nvar + if (dabs(x%data(i, j) - y%data(i, j)) > tol) then + failure = 1 + end if + end do end do if (failure == 1) then - print *, ' ' - print *, 'check_vector failure, differences:' - print *, ' i j x y diff' - print *, ' --------------------------------------------' - do j = 1,N - do i = 1,Nvar - if (dabs(x%data(i,j) - y%data(i,j)) > tol) then - print '(2x,2(i4,3x),3(es9.2,1x))', i, j, x%data(i,j), & - y%data(i,j), dabs(x%data(i,j) - y%data(i,j)) - end if - end do - end do - print *, ' --------------------------------------------' - print *, ' ' + print *, ' ' + print *, 'check_vector failure, differences:' + print *, ' i j x y diff' + print *, ' --------------------------------------------' + do j = 1, N + do i = 1, Nvar + if (dabs(x%data(i, j) - y%data(i, j)) > tol) then + print '(2x,2(i4,3x),3(es9.2,1x))', i, j, x%data(i, j), & + y%data(i, j), dabs(x%data(i, j) - y%data(i, j)) + end if + end do + end do + print *, ' --------------------------------------------' + print *, ' ' end if end function check_vector @@ -131,10 +131,9 @@ program main integer(c_int64_t), parameter :: Nvar = 50 type(SUNMatrix), pointer :: sA, sB, sC, sD, sI type(FMat), pointer :: A, Eye - type(N_Vector), pointer :: sW, sX, sY, sZ + type(N_Vector), pointer :: sW, sX, sY, sZ type(FVec), pointer :: X, Y - !======= Internals ============ ! initialize failure total @@ -146,140 +145,139 @@ program main ! create new matrices and vectors sW => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sW)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sX => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sX)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if X => FN_VGetFVec(sX) sY => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sY)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if Y => FN_VGetFVec(sY) sZ => FN_VNew_Fortran(Nvar, N, sunctx) if (.not. associated(sZ)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sA => FSUNMatNew_Fortran(Nvar, N, sunctx) if (.not. associated(sA)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if A => FSUNMatGetFMat(sA) sB => FSUNMatNew_Fortran(Nvar, N, sunctx) if (.not. associated(sB)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if sC => FSUNMatNew_Fortran(Nvar, N, sunctx) if (.not. associated(sC)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if sD => FSUNMatNew_Fortran(Nvar, N, sunctx) if (.not. associated(sD)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if call c_f_pointer(FSUNMatClone_Fortran(sA), sI) if (.not. associated(sI)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if Eye => FSUNMatGetFMat(sI) - ! fill matrices and vectors X%data = 0.d0 Y%data = 0.d0 A%data = 0.d0 Eye%data = 0.d0 - do k = 1,N - do j = 1,Nvar - do i = 1,Nvar - A%data(i,j,k) = 1.d0*i*j/k - end do - Eye%data(j,j,k) = 1.d0 - x%data(j,k) = 1.d0*k/j - y%data(j,k) = 1.d0*j*Nvar - end do + do k = 1, N + do j = 1, Nvar + do i = 1, Nvar + A%data(i, j, k) = 1.d0*i*j/k + end do + Eye%data(j, j, k) = 1.d0 + x%data(j, k) = 1.d0*k/j + y%data(j, k) = 1.d0*j*Nvar + end do end do ! check matrix ID if (FSUNMatGetID(sA) /= SUNMATRIX_CUSTOM) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNMatGetID' - print *, ' Unrecognized vector type', FSUNMatGetID(sA) + fails = fails + 1 + print *, '>>> FAILED test -- FSUNMatGetID' + print *, ' Unrecognized vector type', FSUNMatGetID(sA) else - print *, 'PASSED test -- FSUNMatGetID' + print *, 'PASSED test -- FSUNMatGetID' end if ! test SUNMatZero retval = FSUNMatZero(sB) - if ( (check_matrix_entry(sB, 0.d0, 1.d-14, Nvar, N) /= 0) & - .or. (retval /= SUN_SUCCESS) ) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNMatZero' + if ((check_matrix_entry(sB, 0.d0, 1.d-14, Nvar, N) /= 0) & + .or. (retval /= SUN_SUCCESS)) then + fails = fails + 1 + print *, '>>> FAILED test -- FSUNMatZero' else - print *, 'PASSED test -- FSUNMatZero' + print *, 'PASSED test -- FSUNMatZero' end if ! test SUNMatCopy retval = FSUNMatCopy(sA, sB) - if ( (check_matrix(sA, sB, 1.d-14, Nvar, N) /= 0) & - .or. (retval /= SUN_SUCCESS) ) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNMatCopy' + if ((check_matrix(sA, sB, 1.d-14, Nvar, N) /= 0) & + .or. (retval /= SUN_SUCCESS)) then + fails = fails + 1 + print *, '>>> FAILED test -- FSUNMatCopy' else - print *, 'PASSED test -- FSUNMatCopy' + print *, 'PASSED test -- FSUNMatCopy' end if ! test SUNMatScaleAdd retval = FSUNMatCopy(sA, sB) retval = FSUNMatScaleAdd(-1.d0, sB, sB) - if ( (check_matrix_entry(sB, 0.d0, 1.d-14, Nvar, N) /= 0) & - .or. (retval /= SUN_SUCCESS) ) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNMatScaleAdd case 1' + if ((check_matrix_entry(sB, 0.d0, 1.d-14, Nvar, N) /= 0) & + .or. (retval /= SUN_SUCCESS)) then + fails = fails + 1 + print *, '>>> FAILED test -- FSUNMatScaleAdd case 1' else - print *, 'PASSED test -- FSUNMatScaleAdd case 1' + print *, 'PASSED test -- FSUNMatScaleAdd case 1' end if retval = FSUNMatCopy(sA, sD) retval = FSUNMatCopy(sI, sC) retval = FSUNMatScaleAdd(1.d0, sD, sI) - if (retval == SUN_SUCCESS) retval = FSUNMatScaleAdd(1.d0, sC, sA) - if ( (check_matrix(sD, sC, 1.d-14, Nvar, N) /= 0) & - .or. (retval /= SUN_SUCCESS) ) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNMatScaleAdd case 2' + if (retval == SUN_SUCCESS) retval = FSUNMatScaleAdd(1.d0, sC, sA) + if ((check_matrix(sD, sC, 1.d-14, Nvar, N) /= 0) & + .or. (retval /= SUN_SUCCESS)) then + fails = fails + 1 + print *, '>>> FAILED test -- FSUNMatScaleAdd case 2' else - print *, 'PASSED test -- FSUNMatScaleAdd case 2' + print *, 'PASSED test -- FSUNMatScaleAdd case 2' end if ! test SUNMatScaleAddI retval = FSUNMatCopy(sI, sB) retval = FSUNMatScaleAddI(-1.d0, sB) - if ( (check_matrix_entry(sB, 0.d0, 1.d-14, Nvar, N) /= 0) & - .or. (retval /= SUN_SUCCESS) ) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNMatScaleAddI' + if ((check_matrix_entry(sB, 0.d0, 1.d-14, Nvar, N) /= 0) & + .or. (retval /= SUN_SUCCESS)) then + fails = fails + 1 + print *, '>>> FAILED test -- FSUNMatScaleAddI' else - print *, 'PASSED test -- FSUNMatScaleAddI' + print *, 'PASSED test -- FSUNMatScaleAddI' end if ! test SUNMatMatvec @@ -287,12 +285,12 @@ program main retval = FSUNMatScaleAddI(3.d0, sB) retval = FSUNMatMatvec(sB, sX, sZ) call FN_VLinearSum(3.d0, sY, 1.d0, sX, sW) - if ( (check_vector(sW, sZ, 1.d-15*Nvar*Nvar, Nvar, N) /= 0) & - .or. (retval /= SUN_SUCCESS) ) then - fails = fails + 1 - print *, '>>> FAILED test -- FSUNMatMatvec' + if ((check_vector(sW, sZ, 1.d-15*Nvar*Nvar, Nvar, N) /= 0) & + .or. (retval /= SUN_SUCCESS)) then + fails = fails + 1 + print *, '>>> FAILED test -- FSUNMatMatvec' else - print *, 'PASSED test -- FSUNMatMatvec' + print *, 'PASSED test -- FSUNMatMatvec' end if ! free matrices and vectors @@ -311,10 +309,10 @@ program main ! print results if (fails > 0) then - print '(a,i3,a)', 'FAIL: FSUNMatrix module failed ',fails,' tests' - stop 1 + print '(a,i3,a)', 'FAIL: FSUNMatrix module failed ', fails, ' tests' + stop 1 else - print *, 'SUCCESS: FSUNMatrix module passed all tests' + print *, 'SUCCESS: FSUNMatrix module passed all tests' end if print *, ' ' diff --git a/examples/arkode/F2003_parallel/ark_brusselator1D_task_local_nls_f2003.f90 b/examples/arkode/F2003_parallel/ark_brusselator1D_task_local_nls_f2003.f90 index 297b036559..f35968c09b 100644 --- a/examples/arkode/F2003_parallel/ark_brusselator1D_task_local_nls_f2003.f90 +++ b/examples/arkode/F2003_parallel/ark_brusselator1D_task_local_nls_f2003.f90 @@ -141,7 +141,7 @@ module ode_mod ! Compute the advection term integer(c_int) function Advection(t, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -153,7 +153,7 @@ integer(c_int) function Advection(t, sunvec_y, sunvec_f, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: ydata(:) @@ -176,29 +176,29 @@ integer(c_int) function Advection(t, sunvec_y, sunvec_f, user_data) & call ExchangeAllStart(sunvec_y) ! Iterate over domain interior, computing advection - tmp = -c / dx + tmp = -c/dx if (c > 0.0d0) then - ! right moving flow - do j = 2,Npts - do i = 1,Nvar - idx1 = i + (j - 1) * Nvar - idx2 = i + (j - 2) * Nvar - fdata(idx1) = tmp * (ydata(idx1) - ydata(idx2)) - end do - end do + ! right moving flow + do j = 2, Npts + do i = 1, Nvar + idx1 = i + (j - 1)*Nvar + idx2 = i + (j - 2)*Nvar + fdata(idx1) = tmp*(ydata(idx1) - ydata(idx2)) + end do + end do else if (c < 0.0d0) then - ! left moving flow - do j = 1,Npts - 1 - do i = 1,Nvar - idx1 = i + (j - 1) * Nvar - idx2 = i + j * Nvar - fdata(idx1) = tmp * (ydata(idx2) - ydata(idx1)) - end do - end do + ! left moving flow + do j = 1, Npts - 1 + do i = 1, Nvar + idx1 = i + (j - 1)*Nvar + idx2 = i + j*Nvar + fdata(idx1) = tmp*(ydata(idx2) - ydata(idx1)) + end do + end do end if @@ -208,14 +208,14 @@ integer(c_int) function Advection(t, sunvec_y, sunvec_f, user_data) & ! compute advection at local boundaries if (c > 0.0d0) then - ! right moving flow (left boundary) - fdata(1:Nvar) = tmp * (ydata(1:Nvar) - Wrecv) + ! right moving flow (left boundary) + fdata(1:Nvar) = tmp*(ydata(1:Nvar) - Wrecv) else if (c < 0.0) then - ! left moving flow (right boundary) - fdata(Nvar * Npts - 2 : Nvar * Npts) = & - tmp * (Erecv - ydata(Nvar * Npts-2 : Nvar * Npts)) + ! left moving flow (right boundary) + fdata(Nvar*Npts - 2:Nvar*Npts) = & + tmp*(Erecv - ydata(Nvar*Npts - 2:Nvar*Npts)) end if @@ -224,10 +224,9 @@ integer(c_int) function Advection(t, sunvec_y, sunvec_f, user_data) & end function Advection - ! Compute the reaction term integer(c_int) function Reaction(t, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -239,7 +238,7 @@ integer(c_int) function Reaction(t, sunvec_y, sunvec_f, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: ydata(:) @@ -258,40 +257,40 @@ integer(c_int) function Reaction(t, sunvec_y, sunvec_f, user_data) & ! iterate over domain, computing reactions if (explicit) then - ! when integrating explicitly, we add to ydot as we expect it - ! to hold the advection term already - do j = 1,Npts + ! when integrating explicitly, we add to ydot as we expect it + ! to hold the advection term already + do j = 1, Npts - idx = (j - 1) * Nvar + idx = (j - 1)*Nvar - u = ydata(idx + 1) - v = ydata(idx + 2) - w = ydata(idx + 3) + u = ydata(idx + 1) + v = ydata(idx + 2) + w = ydata(idx + 3) - fdata(idx + 1) = fdata(idx + 1) + k1 * A - k2 * w * u + k3 * u * u * v - k4 * u - fdata(idx + 2) = fdata(idx + 2) + k2 * w * u - k3 * u * u * v - fdata(idx + 3) = fdata(idx + 3) - k2 * w * u + k5 * B - k6 * w + fdata(idx + 1) = fdata(idx + 1) + k1*A - k2*w*u + k3*u*u*v - k4*u + fdata(idx + 2) = fdata(idx + 2) + k2*w*u - k3*u*u*v + fdata(idx + 3) = fdata(idx + 3) - k2*w*u + k5*B - k6*w - end do + end do else - ! set output to zero - fdata = 0.0d0 + ! set output to zero + fdata = 0.0d0 - do j = 1,Npts + do j = 1, Npts - idx = (j - 1) * Nvar + idx = (j - 1)*Nvar - u = ydata(idx + 1) - v = ydata(idx + 2) - w = ydata(idx + 3) + u = ydata(idx + 1) + v = ydata(idx + 2) + w = ydata(idx + 3) - fdata(idx + 1) = k1 * A - k2 * w * u + k3 * u * u * v - k4 * u - fdata(idx + 2) = k2 * w * u - k3 * u * u * v - fdata(idx + 3) = -k2 * w * u + k5 * B - k6 * w + fdata(idx + 1) = k1*A - k2*w*u + k3*u*u*v - k4*u + fdata(idx + 2) = k2*w*u - k3*u*u*v + fdata(idx + 3) = -k2*w*u + k5*B - k6*w - end do + end do end if @@ -300,10 +299,9 @@ integer(c_int) function Reaction(t, sunvec_y, sunvec_f, user_data) & end function Reaction - ! Compute the RHS as Advection + Reaction integer(c_int) function AdvectionReaction(t, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -315,7 +313,7 @@ integer(c_int) function AdvectionReaction(t, sunvec_y, sunvec_f, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data !======= Internals ============ @@ -335,7 +333,6 @@ end function AdvectionReaction end module ode_mod - module prec_mod !======= Inclusions =========== @@ -348,7 +345,7 @@ module prec_mod ! preconditioner data type(SUNLinearSolver), pointer :: sunls_P ! linear solver - type(SUNMatrix), pointer :: sunmat_P ! matrix + type(SUNMatrix), pointer :: sunmat_P ! matrix contains @@ -358,13 +355,13 @@ module prec_mod ! Sets P = I - gamma * J integer(c_int) function PSetup(t, sunvec_y, sunvec_f, jok, jcurPtr, gamma, & - user_data) result(ierr) bind(C) + user_data) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding use fsunmatrix_dense_mod use fsunlinsol_dense_mod - use ode_mod, only : Nvar, Npts, Neq, k2, k3, k4, k6, myindextype + use ode_mod, only: Nvar, Npts, Neq, k2, k3, k4, k6, myindextype !======= Declarations ========= implicit none @@ -376,7 +373,7 @@ integer(c_int) function PSetup(t, sunvec_y, sunvec_f, jok, jcurPtr, gamma, & integer(c_int), value :: jok ! flag to signal for Jacobian update integer(c_int) :: jcurPtr ! flag to singal Jacobian is current real(c_double), value :: gamma ! current gamma value - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local variables real(c_double), pointer :: ydata(:) ! vector data @@ -394,67 +391,67 @@ integer(c_int) function PSetup(t, sunvec_y, sunvec_f, jok, jcurPtr, gamma, & ! update Jacobian if (jok == 0) then - ! zero the matrix - ierr = FSUNMatZero(sunmat_P) - if (ierr /= 0) then - print *, "Error: FSUNMatZero returned ",ierr - return - end if + ! zero the matrix + ierr = FSUNMatZero(sunmat_P) + if (ierr /= 0) then + print *, "Error: FSUNMatZero returned ", ierr + return + end if - ! setup the block diagonal preconditioner matrix - do i = 1,Npts + ! setup the block diagonal preconditioner matrix + do i = 1, Npts - ! set nodal value shortcuts - idx = (i - 1) * Nvar + ! set nodal value shortcuts + idx = (i - 1)*Nvar - u = ydata(idx + 1) - v = ydata(idx + 2) - w = ydata(idx + 3) + u = ydata(idx + 1) + v = ydata(idx + 2) + w = ydata(idx + 3) - ! fill in Jacobian entries for this mesh node + ! fill in Jacobian entries for this mesh node - ! first column (derivative with respect to u) - offset = (i - 1) * Nvar * Neq + (i - 1) * Nvar + ! first column (derivative with respect to u) + offset = (i - 1)*Nvar*Neq + (i - 1)*Nvar - pdata(offset + 1) = -k2 * w + 2.0d0 * k3 * u * v - k4 - pdata(offset + 2) = k2 * w - 2.0d0 * k3 * u * v - pdata(offset + 3) = -k2 * w + pdata(offset + 1) = -k2*w + 2.0d0*k3*u*v - k4 + pdata(offset + 2) = k2*w - 2.0d0*k3*u*v + pdata(offset + 3) = -k2*w - ! second column (derivative with respect to v) - offset = offset + Nvar * Npts + ! second column (derivative with respect to v) + offset = offset + Nvar*Npts - pdata(offset + 1) = k3 * u * u - pdata(offset + 2) = -k3 * u * u - pdata(offset + 3) = 0.0d0 + pdata(offset + 1) = k3*u*u + pdata(offset + 2) = -k3*u*u + pdata(offset + 3) = 0.0d0 - ! thrid column (derivative with respect to v) - offset = offset + Neq + ! thrid column (derivative with respect to v) + offset = offset + Neq - pdata(offset + 1) = -k2 * u - pdata(offset + 2) = k2 * u - pdata(offset + 3) = -k2 * u - k6 + pdata(offset + 1) = -k2*u + pdata(offset + 2) = k2*u + pdata(offset + 3) = -k2*u - k6 - end do + end do - ierr = FSUNMatScaleAddI(-gamma, sunmat_P) - if (ierr /= 0) then - print *, "Error: FSUNMatScaleAddI returned ",ierr - return - end if + ierr = FSUNMatScaleAddI(-gamma, sunmat_P) + if (ierr /= 0) then + print *, "Error: FSUNMatScaleAddI returned ", ierr + return + end if - ! setup the linear system Pz = r - ierr = FSUNLinSolSetup(sunls_P, sunmat_P) - if (ierr /= 0) then - print *, "Error: FSUNLinSolSetup returned ",ierr - return - end if + ! setup the linear system Pz = r + ierr = FSUNLinSolSetup(sunls_P, sunmat_P) + if (ierr /= 0) then + print *, "Error: FSUNLinSolSetup returned ", ierr + return + end if - ! indicate that J is now current - jcurPtr = 1 + ! indicate that J is now current + jcurPtr = 1 else - jcurPtr = 0 + jcurPtr = 0 end if @@ -463,10 +460,9 @@ integer(c_int) function PSetup(t, sunvec_y, sunvec_f, jok, jcurPtr, gamma, & end function PSetup - ! Solves Pz = r integer(c_int) function PSolve(t, sunvec_y, sunvec_f, sunvec_r, sunvec_z, & - gamma, delta, lr, user_data) result(ierr) bind(C) + gamma, delta, lr, user_data) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -484,7 +480,7 @@ integer(c_int) function PSolve(t, sunvec_y, sunvec_f, sunvec_r, sunvec_z, & real(c_double), value :: gamma ! current gamma value real(c_double), value :: delta ! current gamma value integer(c_int), value :: lr ! left or right preconditioning - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! shortcuts type(N_Vector), pointer :: z_local ! z vector data @@ -498,8 +494,8 @@ integer(c_int) function PSolve(t, sunvec_y, sunvec_f, sunvec_r, sunvec_z, & ! solve the task-local linear system Pz = r ierr = FSUNLinSolSolve(sunls_P, sunmat_P, z_local, r_local, delta) if (ierr /= 0) then - print *, "Error: FSUNLinSolSolver returned ",ierr - return + print *, "Error: FSUNLinSolSolver returned ", ierr + return end if ! return success @@ -509,7 +505,6 @@ end function PSolve end module prec_mod - module nls_mod !======= Inclusions =========== @@ -533,8 +528,8 @@ module nls_mod type(c_ptr) :: sdata_ptr ! residual data ! node local linear solver and data - type(N_Vector), pointer :: sunvec_bnode ! node lobal rhs/solution vec - type(SUNMatrix), pointer :: sunmat_Jnode ! node local Jacobian + type(N_Vector), pointer :: sunvec_bnode ! node lobal rhs/solution vec + type(SUNMatrix), pointer :: sunmat_Jnode ! node local Jacobian type(SUNLinearSolver), pointer :: sunls_Jnode ! node local linear solver ! nonlinear solver counters @@ -548,13 +543,13 @@ module nls_mod ! -------------------------------------------------------------- integer(c_int) function TaskLocalNlsResidual(sunvec_zcor, sunvec_F, arkode_mem) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding use farkode_mod use farkode_arkstep_mod - use ode_mod, only : Neq, Reaction, myindextype + use ode_mod, only: Neq, Reaction, myindextype !======= Declarations ========= implicit none @@ -592,29 +587,29 @@ integer(c_int) function TaskLocalNlsResidual(sunvec_zcor, sunvec_F, arkode_mem) ! get nonlinear residual data ierr = FARKodeGetNonlinearSystemData(arkmem, tcur, zpred_ptr, z_ptr, & - Fi_ptr, gam, sdata_ptr, user_data) + Fi_ptr, gam, sdata_ptr, user_data) if (ierr /= 0) then - print *, "Error: FARKodeGetNonlinearSystemData returned ",ierr - return + print *, "Error: FARKodeGetNonlinearSystemData returned ", ierr + return end if ! get vectors from pointers sunvec_zpred => FN_VGetVecAtIndexVectorArray(zpred_ptr, 0) - sunvec_z => FN_VGetVecAtIndexVectorArray(z_ptr, 0) - sunvec_Fi => FN_VGetVecAtIndexVectorArray(Fi_ptr, 0) + sunvec_z => FN_VGetVecAtIndexVectorArray(z_ptr, 0) + sunvec_Fi => FN_VGetVecAtIndexVectorArray(Fi_ptr, 0) sunvec_sdata => FN_VGetVecAtIndexVectorArray(sdata_ptr, 0) ! get vector data arrays - ycor_data => FN_VGetArrayPointer(sunvec_zcor) - F_data => FN_VGetArrayPointer(sunvec_F) + ycor_data => FN_VGetArrayPointer(sunvec_zcor) + F_data => FN_VGetArrayPointer(sunvec_F) zpred_data => FN_VGetArrayPointer(sunvec_zpred) - z_data => FN_VGetArrayPointer(sunvec_z) - Fi_data => FN_VGetArrayPointer(sunvec_Fi) + z_data => FN_VGetArrayPointer(sunvec_z) + Fi_data => FN_VGetArrayPointer(sunvec_Fi) sdata_data => FN_VGetArrayPointer(sunvec_sdata) ! update "z" value as stored predictor + current corrector - do i = 1,Neq - z_data(i) = zpred_data(i) + ycor_data(i) + do i = 1, Neq + z_data(i) = zpred_data(i) + ycor_data(i) end do ! compute implicit RHS and save for later @@ -625,13 +620,13 @@ integer(c_int) function TaskLocalNlsResidual(sunvec_zcor, sunvec_F, arkode_mem) ! check RHS return value if (ierr /= 0) then - print *, "Error: Reaction returned ",ierr - return + print *, "Error: Reaction returned ", ierr + return end if ! compute the nonlinear resiudal - do i = 1,Neq - F_data(i) = ycor_data(i) - sdata_data(i) - gam(1) * Fi_data(i) + do i = 1, Neq + F_data(i) = ycor_data(i) - sdata_data(i) - gam(1)*Fi_data(i) end do ! return success @@ -639,16 +634,15 @@ integer(c_int) function TaskLocalNlsResidual(sunvec_zcor, sunvec_F, arkode_mem) end function TaskLocalNlsResidual - integer(c_int) function TaskLocalLSolve(sunvec_delta, arkode_mem) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding use farkode_mod use farkode_arkstep_mod use fsunmatrix_dense_mod - use ode_mod, only : Nvar, Npts, k2, k3, k4, k6, myindextype + use ode_mod, only: Nvar, Npts, k2, k3, k4, k6, myindextype !======= Declarations ========= implicit none @@ -678,10 +672,10 @@ integer(c_int) function TaskLocalLSolve(sunvec_delta, arkode_mem) & ! get nonlinear residual data ierr = FARKodeGetNonlinearSystemData(arkmem, tcur, zpred_ptr, z_ptr, & - Fi_ptr, gam, sdata_ptr, user_data) + Fi_ptr, gam, sdata_ptr, user_data) if (ierr /= 0) then - print *, "Error: FARKodeGetNonlinearSystemData returned ",ierr - return + print *, "Error: FARKodeGetNonlinearSystemData returned ", ierr + return end if ! get vectors from pointers @@ -695,59 +689,59 @@ integer(c_int) function TaskLocalLSolve(sunvec_delta, arkode_mem) & bnode_data => FN_VGetArrayPointer(sunvec_bnode) ! solve the linear system at each mesh node - do i = 1,Npts - - ! set nodal value shortcuts - idx = (i - 1) * Nvar - - u = z_data(idx + 1) - v = z_data(idx + 2) - w = z_data(idx + 3) - - ! fill in Jacobian entries for this mesh node - - ! first column (derivative with respect to u) - J_data(1) = -k2 * w + 2.0d0 * k3 * u * v - k4 - J_data(2) = k2 * w - 2.0d0 * k3 * u * v - J_data(3) = -k2 * w - - ! second column (derivative with respect to v) - J_data(4) = k3 * u * u - J_data(5) = -k3 * u * u - J_data(6) = 0.0d0 - - ! thrid column (derivative with respect to v) - J_data(7) = -k2 * u - J_data(8) = k2 * u - J_data(9) = -k2 * u - k6 - - ! I - gamma*J - ierr = FSUNMatScaleAddI(-gam(1), sunmat_Jnode) - if (ierr /= 0) then - print *, "Error: FSUNMatScaleAddI returned ",ierr - return - end if - - ! grab just the portion of the vector "b" for this mesh node - bnode_data = b_data(idx + 1 : idx + 3) - - ! setup the linear system - ierr = FSUNLinSolSetup(sunls_Jnode, sunmat_Jnode) - if (ierr /= 0) then - print *, "Error: FSUNLinSolSolSetup returned ",ierr - return - end if - - ! solve the linear system - ierr = FSUNLinSolSolve(sunls_Jnode, sunmat_Jnode, sunvec_bnode, & - sunvec_bnode, 0.0d0) - if (ierr /= 0) then - print *, "Error: FSUNLinSolSolve returned ",ierr - return - end if - - ! set just the portion of the vector "b" for this mesh node - b_data(idx + 1 : idx + 3) = bnode_data + do i = 1, Npts + + ! set nodal value shortcuts + idx = (i - 1)*Nvar + + u = z_data(idx + 1) + v = z_data(idx + 2) + w = z_data(idx + 3) + + ! fill in Jacobian entries for this mesh node + + ! first column (derivative with respect to u) + J_data(1) = -k2*w + 2.0d0*k3*u*v - k4 + J_data(2) = k2*w - 2.0d0*k3*u*v + J_data(3) = -k2*w + + ! second column (derivative with respect to v) + J_data(4) = k3*u*u + J_data(5) = -k3*u*u + J_data(6) = 0.0d0 + + ! thrid column (derivative with respect to v) + J_data(7) = -k2*u + J_data(8) = k2*u + J_data(9) = -k2*u - k6 + + ! I - gamma*J + ierr = FSUNMatScaleAddI(-gam(1), sunmat_Jnode) + if (ierr /= 0) then + print *, "Error: FSUNMatScaleAddI returned ", ierr + return + end if + + ! grab just the portion of the vector "b" for this mesh node + bnode_data = b_data(idx + 1:idx + 3) + + ! setup the linear system + ierr = FSUNLinSolSetup(sunls_Jnode, sunmat_Jnode) + if (ierr /= 0) then + print *, "Error: FSUNLinSolSolSetup returned ", ierr + return + end if + + ! solve the linear system + ierr = FSUNLinSolSolve(sunls_Jnode, sunmat_Jnode, sunvec_bnode, & + sunvec_bnode, 0.0d0) + if (ierr /= 0) then + print *, "Error: FSUNLinSolSolve returned ", ierr + return + end if + + ! set just the portion of the vector "b" for this mesh node + b_data(idx + 1:idx + 3) = bnode_data end do @@ -756,9 +750,8 @@ integer(c_int) function TaskLocalLSolve(sunvec_delta, arkode_mem) & end function TaskLocalLSolve - integer(SUNNonlinearSolver_Type) function TaskLocalNewton_GetType(sunnls) & - result(id) bind(C) + result(id) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -775,9 +768,8 @@ integer(SUNNonlinearSolver_Type) function TaskLocalNewton_GetType(sunnls) & end function TaskLocalNewton_GetType - integer(c_int) function TaskLocalNewton_Initialize(sunnls) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -793,20 +785,20 @@ integer(c_int) function TaskLocalNewton_Initialize(sunnls) & ! override default system and lsolve functions with local versions ierr = FSUNNonlinSolSetSysFn(sunnls_LOC, c_funloc(TaskLocalNlsResidual)) if (ierr /= 0) then - print *, "Error: FSUNNonlinSolSetSysFn returned ",ierr - return + print *, "Error: FSUNNonlinSolSetSysFn returned ", ierr + return end if ierr = FSUNNonlinSolSetLSolveFn(sunnls_LOC, c_funloc(TaskLocalLSolve)) if (ierr /= 0) then - print *, "Error: FSUNNonlinSolSetLSolveFn returned ",ierr - return + print *, "Error: FSUNNonlinSolSetLSolveFn returned ", ierr + return end if ierr = FSUNNonlinSolInitialize(sunnls_LOC) if (ierr /= 0) then - print *, "Error: FSUNNonlinSolSetLSolveFn returned ",ierr - return + print *, "Error: FSUNNonlinSolSetLSolveFn returned ", ierr + return end if ! return success @@ -814,14 +806,13 @@ integer(c_int) function TaskLocalNewton_Initialize(sunnls) & end function TaskLocalNewton_Initialize - integer(c_int) function TaskLocalNewton_Solve(sunnls, sunvec_y0, sunvec_ycor, & - sunvec_w, tol, callLSetup, arkode_mem) result(ierr) bind(C) + sunvec_w, tol, callLSetup, arkode_mem) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding use fnvector_mpiplusx_mod - use ode_mod, only : comm + use ode_mod, only: comm !======= Declarations ========= implicit none @@ -849,33 +840,32 @@ integer(c_int) function TaskLocalNewton_Solve(sunnls, sunvec_y0, sunvec_ycor, & !======= Internals ============ ! get MPI task local vectors - sunvec_y0loc => FN_VGetLocalVector_MPIPlusX(sunvec_y0) + sunvec_y0loc => FN_VGetLocalVector_MPIPlusX(sunvec_y0) sunvec_ycorloc => FN_VGetLocalVector_MPIPlusX(sunvec_ycor) - sunvec_wloc => FN_VGetLocalVector_MPIPlusX(sunvec_w) + sunvec_wloc => FN_VGetLocalVector_MPIPlusX(sunvec_w) ! each tasks solves the local nonlinear system ierr = FSUNNonlinSolSolve(sunnls_LOC, sunvec_y0loc, sunvec_ycorloc, & - sunvec_wloc, tol, callLSetup, arkode_mem) + sunvec_wloc, tol, callLSetup, arkode_mem) solve_status = ierr ! if any process had a nonrecoverable failure, return it call MPI_Allreduce(solve_status, nonrecover, 1, MPI_INTEGER, MPI_MIN, comm, & - mpi_ierr) + mpi_ierr) ierr = nonrecover if (ierr < 0) return ! check if any process has a recoverable convergence failure and return ! success (recover == 0) or a recoverable error code (recover > 0) call MPI_Allreduce(solve_status, recover, 1, MPI_INTEGER, MPI_MAX, comm, & - mpi_ierr) + mpi_ierr) ierr = recover if (ierr /= 0) ncnf_loc = ncnf_loc + 1 end function TaskLocalNewton_Solve - integer(c_int) function TaskLocalNewton_Free(sunnls) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -900,9 +890,8 @@ integer(c_int) function TaskLocalNewton_Free(sunnls) & end function TaskLocalNewton_Free - integer(c_int) function TaskLocalNewton_SetSysFn(sunnls, SysFn) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -920,9 +909,8 @@ integer(c_int) function TaskLocalNewton_SetSysFn(sunnls, SysFn) & end function TaskLocalNewton_SetSysFn - integer(c_int) function TaskLocalNewton_SetConvTestFn(sunnls, CTestFn, & - ctest_data) result(ierr) bind(C) + ctest_data) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -941,9 +929,8 @@ integer(c_int) function TaskLocalNewton_SetConvTestFn(sunnls, CTestFn, & end function TaskLocalNewton_SetConvTestFn - integer(c_int) function TaskLocalNewton_GetNumConvFails(sunnls, nconvfails) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -964,7 +951,6 @@ integer(c_int) function TaskLocalNewton_GetNumConvFails(sunnls, nconvfails) & end function TaskLocalNewton_GetNumConvFails - function TaskLocalNewton(arkode_mem, sunvec_y) result(sunnls) !======= Inclusions =========== @@ -983,7 +969,7 @@ function TaskLocalNewton(arkode_mem, sunvec_y) result(sunnls) type(c_ptr), target, intent(in) :: arkode_mem ! ARKODE memory type(N_Vector) :: sunvec_y ! solution N_Vector - type(SUNNonlinearSolver), pointer :: sunnls ! SUNDIALS nonlinear solver + type(SUNNonlinearSolver), pointer :: sunnls ! SUNDIALS nonlinear solver type(SUNNonlinearSolver_Ops), pointer :: nlsops ! solver operations integer :: ierr ! MPI error status @@ -996,20 +982,20 @@ function TaskLocalNewton(arkode_mem, sunvec_y) result(sunnls) ! Create an empty nonlinear linear solver object sunnls => FSUNNonlinSolNewEmpty(sunctx) if (.not. associated(sunnls)) then - print *, "Error: FSUNNonlinSolNewEmpty returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNNonlinSolNewEmpty returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Access the SUNNonlinearSolver ops structure call c_f_pointer(sunnls%ops, nlsops) ! Attach operations - nlsops%gettype = c_funloc(TaskLocalNewton_GetType) - nlsops%initialize = c_funloc(TaskLocalNewton_Initialize) - nlsops%solve = c_funloc(TaskLocalNewton_Solve) - nlsops%free = c_funloc(TaskLocalNewton_Free) - nlsops%setsysfn = c_funloc(TaskLocalNewton_SetSysFn) - nlsops%setctestfn = c_funloc(TaskLocalNewton_SetConvTestFn) + nlsops%gettype = c_funloc(TaskLocalNewton_GetType) + nlsops%initialize = c_funloc(TaskLocalNewton_Initialize) + nlsops%solve = c_funloc(TaskLocalNewton_Solve) + nlsops%free = c_funloc(TaskLocalNewton_Free) + nlsops%setsysfn = c_funloc(TaskLocalNewton_SetSysFn) + nlsops%setctestfn = c_funloc(TaskLocalNewton_SetConvTestFn) nlsops%getnumconvfails = c_funloc(TaskLocalNewton_GetNumConvFails) ! Create the task local Newton solver @@ -1017,23 +1003,22 @@ function TaskLocalNewton(arkode_mem, sunvec_y) result(sunnls) ! Create vector pointers to receive residual data zpred_ptr = FN_VNewVectorArray(1, sunctx) - z_ptr = FN_VNewVectorArray(1, sunctx) - Fi_ptr = FN_VNewVectorArray(1, sunctx) + z_ptr = FN_VNewVectorArray(1, sunctx) + Fi_ptr = FN_VNewVectorArray(1, sunctx) sdata_ptr = FN_VNewVectorArray(1, sunctx) sunvec_bnode => FN_VNew_Serial(Nvar, sunctx) sunmat_Jnode => FSUNDenseMatrix(Nvar, Nvar, sunctx) - sunls_Jnode => FSUNLinSol_Dense(sunvec_bnode, sunmat_Jnode, sunctx) + sunls_Jnode => FSUNLinSol_Dense(sunvec_bnode, sunmat_Jnode, sunctx) ! initialize number of nonlinear solver function evals and fails - nnlfi = 0 + nnlfi = 0 ncnf_loc = 0 end function TaskLocalNewton end module nls_mod - program main !======= Inclusions =========== @@ -1043,8 +1028,8 @@ program main use fnvector_mpimanyvector_mod ! Access MPIManyVector N_Vector use fnvector_serial_mod ! Access serial N_Vector - use ode_mod, only : sunctx, logger, comm, myid, Nx, Neq, dx, fused, & - explicit, printtime, nout, myindextype + use ode_mod, only: sunctx, logger, comm, myid, Nx, Neq, dx, fused, & + explicit, printtime, nout, myindextype !======= Declarations ========= implicit none @@ -1065,8 +1050,8 @@ program main ! Initialize MPI call MPI_Init(ierr) if (ierr /= 0) then - print *, "Error: MPI_Init returned ",ierr - stop 1 + print *, "Error: MPI_Init returned ", ierr + stop 1 end if ! Start timing @@ -1076,7 +1061,7 @@ program main comm = MPI_COMM_WORLD retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ",retval + print *, "Error: FSUNContext_Create returned ", retval call MPI_Abort(comm, 1, ierr) end if @@ -1094,19 +1079,19 @@ program main ! desired levels. We will enable informational logging here: retval = FSUNLogger_Create(comm, 0, logger) if (retval /= 0) then - print *, "Error: FSUNLogger_Create returned ",retval + print *, "Error: FSUNLogger_Create returned ", retval call MPI_Abort(comm, 1, ierr) end if retval = FSUNLogger_SetInfoFilename(logger, "sundials.log") if (retval /= 0) then - print *, "Error: FSUNLogger_SetInfoFilename returned ",retval + print *, "Error: FSUNLogger_SetInfoFilename returned ", retval call MPI_Abort(comm, 1, ierr) end if retval = FSUNContext_SetLogger(sunctx, logger) if (retval /= 0) then - print *, "Error: FSUNContext_SetLogger returned ",retval + print *, "Error: FSUNContext_SetLogger returned ", retval call MPI_Abort(comm, 1, ierr) end if @@ -1115,21 +1100,21 @@ program main ! Create solution vector sunvec_ys => FN_VNew_Serial(Neq, sunctx) - sunvec_y => FN_VMake_MPIPlusX(comm, sunvec_ys, sunctx) + sunvec_y => FN_VMake_MPIPlusX(comm, sunvec_ys, sunctx) ! Enable fused vector ops in local and MPI+X vectors if (fused) then - retval = FN_VEnableFusedOps_Serial(sunvec_ys, SUNTRUE) - if (retval /= 0) then - print *, "Error: FN_VEnableFusedOps_Serial returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FN_VEnableFusedOps_MPIManyVector(sunvec_y, SUNTRUE) - if (retval /= 0) then - print *, "Error: FN_VEnableFusedOps_MPIManyVector returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FN_VEnableFusedOps_Serial(sunvec_ys, SUNTRUE) + if (retval /= 0) then + print *, "Error: FN_VEnableFusedOps_Serial returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FN_VEnableFusedOps_MPIManyVector(sunvec_y, SUNTRUE) + if (retval /= 0) then + print *, "Error: FN_VEnableFusedOps_MPIManyVector returned ", retval + call MPI_Abort(comm, 1, ierr) + end if end if ! Set the initial condition @@ -1137,24 +1122,24 @@ program main ! Output spatial mesh to disk (add extra point for periodic BC if (myid == 0 .and. nout > 0) then - open(99, file="mesh.txt") - do i = 0, Nx - write(99, "(es23.16)") dx * i - end do + open (99, file="mesh.txt") + do i = 0, Nx + write (99, "(es23.16)") dx*i + end do end if ! Integrate in time if (explicit) then - call EvolveProblemExplicit(sunvec_y) + call EvolveProblemExplicit(sunvec_y) else - call EvolveProblemIMEX(sunvec_y) + call EvolveProblemIMEX(sunvec_y) end if ! End timing endtime = MPI_Wtime() if (myid == 0 .and. printtime) then - print "(A,es12.5,A)", "Total wall clock time: ",endtime-starttime," sec" + print "(A,es12.5,A)", "Total wall clock time: ", endtime - starttime, " sec" end if ! Finalize MPI @@ -1165,7 +1150,6 @@ program main end program main - ! Setup ARKODE and evolve problem in time with IMEX method subroutine EvolveProblemIMEX(sunvec_y) @@ -1179,12 +1163,12 @@ subroutine EvolveProblemIMEX(sunvec_y) use fsunlinsol_spgmr_mod ! Access GMRES SUNLinearSolver use fsunnonlinsol_newton_mod ! Access Newton SUNNonlinearSolver - use ode_mod, only : sunctx, comm, myid, Neq, t0, tf, atol, rtol, order, & - monitor, global, nout, umask_s, Advection, Reaction + use ode_mod, only: sunctx, comm, myid, Neq, t0, tf, atol, rtol, order, & + monitor, global, nout, umask_s, Advection, Reaction - use prec_mod, only : sunls_P, sunmat_P, PSetup, PSolve + use prec_mod, only: sunls_P, sunmat_P, PSetup, PSolve - use nls_mod, only : nnlfi, TaskLocalNewton + use nls_mod, only: nnlfi, TaskLocalNewton !======= Declarations ========= implicit none @@ -1211,8 +1195,8 @@ subroutine EvolveProblemIMEX(sunvec_y) integer(c_long) :: npsol(1) ! number of preconditioner solves type(SUNNonlinearSolver), pointer :: sun_NLS ! nonlinear solver - type(SUNLinearSolver), pointer :: sun_LS ! linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNLinearSolver), pointer :: sun_LS ! linear solver + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix integer :: ierr ! MPI error status integer :: iout ! output counter @@ -1226,31 +1210,31 @@ subroutine EvolveProblemIMEX(sunvec_y) ! Create the ARK timestepper module arkode_mem = FARKStepCreate(c_funloc(Advection), c_funloc(Reaction), & - t0, sunvec_y, sunctx) + t0, sunvec_y, sunctx) if (.not. c_associated(arkode_mem)) then - print *, "Error: FARKStepCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKStepCreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Select the method order retval = FARKodeSetOrder(arkode_mem, order) if (retval /= 0) then - print *, "Error: FARKodeSetOrder returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSetOrder returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FARKodeSStolerances(arkode_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FARKodeSStolerances returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Increase the max number of steps allowed between outputs retval = FARKodeSetMaxNumSteps(arkode_mem, int(100000, c_long)) if (retval /= 0) then - print *, "Error: FARKodeMaxNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeMaxNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Create the (non)linear solver @@ -1259,195 +1243,195 @@ subroutine EvolveProblemIMEX(sunvec_y) if (global) then - ! Create nonlinear solver - sun_NLS => FSUNNonlinSol_Newton(sunvec_y, sunctx) - if (.not. associated(sun_NLS)) then - print *, "Error: SUNNonlinSol_Newton returned NULL" - call MPI_Abort(comm, 1, ierr) - end if - - ! Attach nonlinear solver - retval = FARKodeSetNonlinearSolver(arkode_mem, sun_NLS) - if (retval /= 0) then - print *, "Error: FARKodeSetNonlinearSolver returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Create linear solver - sun_LS => FSUNLinSol_SPGMR(sunvec_y, SUN_PREC_LEFT, 0, sunctx) - if (.not. associated(sun_LS)) then - print *, "Error: FSUNLinSol_SPGMR returned NULL" - call MPI_Abort(comm, 1, ierr) - end if - - ! Attach linear solver - sunmat_A => null() - retval = FARKodeSetLinearSolver(arkode_mem, sun_LS, sunmat_A) - if (retval /= 0) then - print *, "Error: FARKodeSetLinearSolver returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Attach preconditioner - retval = FARKodeSetPreconditioner(arkode_mem, c_funloc(PSetup), & - c_funloc(PSolve)) - if (retval /= 0) then - print *, "Error: FARKodeSetPreconditioner returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Create MPI task-local data structures for preconditioning - sunmat_P => FSUNDenseMatrix(Neq, Neq, sunctx) - sunls_P => FSUNLinSol_Dense(umask_s, sunmat_P, sunctx) + ! Create nonlinear solver + sun_NLS => FSUNNonlinSol_Newton(sunvec_y, sunctx) + if (.not. associated(sun_NLS)) then + print *, "Error: SUNNonlinSol_Newton returned NULL" + call MPI_Abort(comm, 1, ierr) + end if + + ! Attach nonlinear solver + retval = FARKodeSetNonlinearSolver(arkode_mem, sun_NLS) + if (retval /= 0) then + print *, "Error: FARKodeSetNonlinearSolver returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Create linear solver + sun_LS => FSUNLinSol_SPGMR(sunvec_y, SUN_PREC_LEFT, 0, sunctx) + if (.not. associated(sun_LS)) then + print *, "Error: FSUNLinSol_SPGMR returned NULL" + call MPI_Abort(comm, 1, ierr) + end if + + ! Attach linear solver + sunmat_A => null() + retval = FARKodeSetLinearSolver(arkode_mem, sun_LS, sunmat_A) + if (retval /= 0) then + print *, "Error: FARKodeSetLinearSolver returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Attach preconditioner + retval = FARKodeSetPreconditioner(arkode_mem, c_funloc(PSetup), & + c_funloc(PSolve)) + if (retval /= 0) then + print *, "Error: FARKodeSetPreconditioner returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Create MPI task-local data structures for preconditioning + sunmat_P => FSUNDenseMatrix(Neq, Neq, sunctx) + sunls_P => FSUNLinSol_Dense(umask_s, sunmat_P, sunctx) else - ! The custom task-local nonlinear solver handles the linear solve - ! as well, so we do not need a SUNLinearSolver - sun_NLS => TaskLocalNewton(arkode_mem, umask_s) - if (.not. associated(sun_NLS)) then - print *, "Error: TaskLocalNewton returned NULL" - call MPI_Abort(comm, 1, ierr) - end if - - ! Attach nonlinear solver - retval = FARKodeSetNonlinearSolver(arkode_mem, sun_NLS) - if (retval /= 0) then - print *, "Error: FARKodeSetNonlinearSolver returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + ! The custom task-local nonlinear solver handles the linear solve + ! as well, so we do not need a SUNLinearSolver + sun_NLS => TaskLocalNewton(arkode_mem, umask_s) + if (.not. associated(sun_NLS)) then + print *, "Error: TaskLocalNewton returned NULL" + call MPI_Abort(comm, 1, ierr) + end if + + ! Attach nonlinear solver + retval = FARKodeSetNonlinearSolver(arkode_mem, sun_NLS) + if (retval /= 0) then + print *, "Error: FARKodeSetNonlinearSolver returned ", retval + call MPI_Abort(comm, 1, ierr) + end if end if ! Set initial time, determine output time, and initialize output count - t(1) = t0 + t(1) = t0 dtout = (tf - t0) if (nout /= 0) then - dtout = dtout / nout + dtout = dtout/nout end if tout = t(1) + dtout iout = 0 ! Output initial condition if (myid == 0 .and. monitor) then - print *, "" - print *, " t ||u||_rms ||v||_rms ||w||_rms" - print *, "-----------------------------------------------------------" + print *, "" + print *, " t ||u||_rms ||v||_rms ||w||_rms" + print *, "-----------------------------------------------------------" end if call WriteOutput(t, sunvec_y) ! Integrate to final time - do while (iout < max(nout,1)) + do while (iout < max(nout, 1)) - ! Integrate to output time - retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) - if (retval /= 0) then - print *, "Error: FARKodeEvolve returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + ! Integrate to output time + retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) + if (retval /= 0) then + print *, "Error: FARKodeEvolve returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - ! Output state - call WriteOutput(t, sunvec_y) + ! Output state + call WriteOutput(t, sunvec_y) - ! Update output time - tout = tout + dtout - if (tout > tf) then - tout = tf - end if + ! Update output time + tout = tout + dtout + if (tout > tf) then + tout = tf + end if - ! Update output count - iout = iout + 1 + ! Update output count + iout = iout + 1 end do if (myid == 0 .and. monitor) then - print *, "-----------------------------------------------------------" - print *, "" + print *, "-----------------------------------------------------------" + print *, "" end if ! Get final statistics retval = FARKodeGetNumSteps(arkode_mem, nst) if (retval /= 0) then - print *, "Error: FARKodeGetNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (retval /= 0) then - print *, "Error: FARKodeGetNumStepAttempts returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumStepAttempts returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (retval /= 0) then - print *, "Error: FARKStepGetNumRhsEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKStepGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumErrTestFails(arkode_mem, netf) if (retval /= 0) then - print *, "Error: FARKodeGetNumErrTestFails returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumNonlinSolvIters(arkode_mem, nni) if (retval /= 0) then - print *, "Error: FARKodeGetNumNonlinSolvIters returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumNonlinSolvIters returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumNonlinSolvConvFails(arkode_mem, ncfn) if (retval /= 0) then - print *, "Error: FARKodeGetNumNonlinSolvConvFails returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumNonlinSolvConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if if (global) then - retval = FARKodeGetNumLinIters(arkode_mem, nli) - if (retval /= 0) then - print *, "Error: FARKodeGetNumLinIters returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FARKodeGetNumLinIters(arkode_mem, nli) + if (retval /= 0) then + print *, "Error: FARKodeGetNumLinIters returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - retval = FARKodeGetNumPrecEvals(arkode_mem, npre) - if (retval /= 0) then - print *, "Error: FARKodeGetNumPrecEvals returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FARKodeGetNumPrecEvals(arkode_mem, npre) + if (retval /= 0) then + print *, "Error: FARKodeGetNumPrecEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - retval = FARKodeGetNumPrecSolves(arkode_mem, npsol) - if (retval /= 0) then - print *, "Error: FARKodeGetNumPrecSolves returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FARKodeGetNumPrecSolves(arkode_mem, npsol) + if (retval /= 0) then + print *, "Error: FARKodeGetNumPrecSolves returned ", retval + call MPI_Abort(comm, 1, ierr) + end if end if ! Print final statistics if (myid == 0) then - print "(A)","Final Solver Statistics (for processor 0):" - print "(2x,A,i0)", "Steps = ",nst - print "(2x,A,i0)", "Step attempts = ",nst_a - print "(2x,A,i0)", "Error test fails = ",netf - print "(2x,A,i0)", "NLS fails = ",ncfn + print "(A)", "Final Solver Statistics (for processor 0):" + print "(2x,A,i0)", "Steps = ", nst + print "(2x,A,i0)", "Step attempts = ", nst_a + print "(2x,A,i0)", "Error test fails = ", netf + print "(2x,A,i0)", "NLS fails = ", ncfn - if (global) then + if (global) then - print "(2x,A,i0)", "RHS evals Fe = ",nfe - print "(2x,A,i0)", "RHS evals Fi = ",nfi - print "(2x,A,i0)", "NLS iters = ",nni - print "(2x,A,i0)", "LS iters = ",nli - print "(2x,A,i0)", "P setups = ",npre - print "(2x,A,i0)", "P solves = ",npsol + print "(2x,A,i0)", "RHS evals Fe = ", nfe + print "(2x,A,i0)", "RHS evals Fi = ", nfi + print "(2x,A,i0)", "NLS iters = ", nni + print "(2x,A,i0)", "LS iters = ", nli + print "(2x,A,i0)", "P setups = ", npre + print "(2x,A,i0)", "P solves = ", npsol - else + else - print "(2x,A,i0)", "RHS evals Fe = ",nfe - print "(2x,A,i0)", "RHS evals Fi = ",nfi + nnlfi + print "(2x,A,i0)", "RHS evals Fe = ", nfe + print "(2x,A,i0)", "RHS evals Fi = ", nfi + nnlfi - end if + end if end if @@ -1457,30 +1441,29 @@ subroutine EvolveProblemIMEX(sunvec_y) ! Free nonlinear solver retval = FSUNNonlinSolFree(sun_NLS) if (retval /= 0) then - print *, "Error: FSUNNonlinSolFree returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNNonlinSolFree returned ", retval + call MPI_Abort(comm, 1, ierr) end if if (global) then - ! free task-local preconditioner solve structures - call FSUNMatDestroy(sunmat_P) - retval = FSUNLinSolFree(sunls_P) - if (retval /= 0) then - print *, "Error: FSUNLinSolFree returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! free global linear solver - retval = FSUNLinSolFree(sun_LS) - if (retval /= 0) then - print *, "Error: FSUNLinSolFree returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + ! free task-local preconditioner solve structures + call FSUNMatDestroy(sunmat_P) + retval = FSUNLinSolFree(sunls_P) + if (retval /= 0) then + print *, "Error: FSUNLinSolFree returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! free global linear solver + retval = FSUNLinSolFree(sun_LS) + if (retval /= 0) then + print *, "Error: FSUNLinSolFree returned ", retval + call MPI_Abort(comm, 1, ierr) + end if end if end subroutine EvolveProblemIMEX - subroutine EvolveProblemExplicit(sunvec_y) !======= Inclusions =========== @@ -1489,8 +1472,8 @@ subroutine EvolveProblemExplicit(sunvec_y) use farkode_mod ! Access ARKode use farkode_erkstep_mod ! Access ERKStep - use ode_mod, only : sunctx, comm, myid, t0, tf, atol, rtol, order, monitor, & - nout, AdvectionReaction + use ode_mod, only: sunctx, comm, myid, t0, tf, atol, rtol, order, monitor, & + nout, AdvectionReaction !======= Declarations ========= implicit none @@ -1519,109 +1502,109 @@ subroutine EvolveProblemExplicit(sunvec_y) ! Create the ERK integrator arkode_mem = FERKStepCreate(c_funloc(AdvectionReaction), t0, sunvec_y, sunctx) if (.not. c_associated(arkode_mem)) then - print *, "Error: FERKStepCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FERKStepCreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Select the method order retval = FARKodeSetOrder(arkode_mem, order) if (retval /= 0) then - print *, "Error: FARKodeSetOrder returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSetOrder returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FARKodeSStolerances(arkode_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FARKodeSStolerances returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Increase the max number of steps allowed between outputs retval = FARKodeSetMaxNumSteps(arkode_mem, int(100000, c_long)) if (retval /= 0) then - print *, "Error: FARKodeMaxNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeMaxNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Set initial time, determine output time, and initialize output count - t(1) = t0 + t(1) = t0 dtout = (tf - t0) if (nout /= 0) then - dtout = dtout / nout + dtout = dtout/nout end if tout = t(1) + dtout iout = 0 ! Ouput initial condition if (myid == 0 .and. monitor) then - print *, "" - print *, " t ||u||_rms ||v||_rms ||w||_rms" - print *, "-----------------------------------------------------------" + print *, "" + print *, " t ||u||_rms ||v||_rms ||w||_rms" + print *, "-----------------------------------------------------------" end if call WriteOutput(t, sunvec_y) ! Integrate to final time do while (iout < nout) - ! Integrate to output time - retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) - if (retval /= 0) then - print *, "Error: FARKodeEvolve returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + ! Integrate to output time + retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) + if (retval /= 0) then + print *, "Error: FARKodeEvolve returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - ! Output state - call WriteOutput(t, sunvec_y) + ! Output state + call WriteOutput(t, sunvec_y) - ! Update output time - tout = tout + dtout - if (tout > tf) then - tout = tf - end if + ! Update output time + tout = tout + dtout + if (tout > tf) then + tout = tf + end if - ! Update output count - iout = iout + 1 + ! Update output count + iout = iout + 1 end do if (myid == 0 .and. monitor) then - print *, "-----------------------------------------------------------" - print *, "" + print *, "-----------------------------------------------------------" + print *, "" end if ! Get final statistics retval = FARKodeGetNumSteps(arkode_mem, nst) if (retval /= 0) then - print *, "Error: FARKodeGetNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (retval /= 0) then - print *, "Error: FARKodeGetNumStepAttempts returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumStepAttempts returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FERKStepGetNumRhsEvals(arkode_mem, nfe) if (retval /= 0) then - print *, "Error: FERKStepGetNumRhsEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FERKStepGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumErrTestFails(arkode_mem, netf) if (retval /= 0) then - print *, "Error: FARKodeGetNumErrTestFails returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Print final statistcs if (myid == 0) then - print "(A)","Final Solver Statistics (for processor 0):" - print "(2x,A,i0)", "Steps = ",nst - print "(2x,A,i0)", "Step attempts = ",nst_a - print "(2x,A,i0)", "Error test fails = ",netf - print "(2x,A,i0)", "RHS evals = ",nfe + print "(A)", "Final Solver Statistics (for processor 0):" + print "(2x,A,i0)", "Steps = ", nst + print "(2x,A,i0)", "Step attempts = ", nst_a + print "(2x,A,i0)", "Error test fails = ", netf + print "(2x,A,i0)", "RHS evals = ", nfe end if ! Clean up @@ -1629,7 +1612,6 @@ subroutine EvolveProblemExplicit(sunvec_y) end subroutine EvolveProblemExplicit - ! Write time and solution to disk subroutine WriteOutput(t, sunvec_y) @@ -1638,8 +1620,8 @@ subroutine WriteOutput(t, sunvec_y) use fsundials_core_mod use farkode_mod ! Access ARKode - use ode_mod, only : Nvar, nprocs, myid, Erecv, Nx, Npts, monitor, nout, & - umask, vmask, wmask, myindextype + use ode_mod, only: Nvar, nprocs, myid, Erecv, Nx, Npts, monitor, nout, & + umask, vmask, wmask, myindextype !======= Declarations ========= implicit none @@ -1659,58 +1641,57 @@ subroutine WriteOutput(t, sunvec_y) ! output current solution norm to screen if (monitor) then - u = FN_VWL2Norm(sunvec_y, umask) - u = sqrt(u * u / Nx) + u = FN_VWL2Norm(sunvec_y, umask) + u = sqrt(u*u/Nx) - v = FN_VWL2Norm(sunvec_y, vmask) - v = sqrt(v * v / Nx) + v = FN_VWL2Norm(sunvec_y, vmask) + v = sqrt(v*v/Nx) - w = FN_VWL2Norm(sunvec_y, wmask) - w = sqrt(w * w / Nx) + w = FN_VWL2Norm(sunvec_y, wmask) + w = sqrt(w*w/Nx) - if (myid == 0) then - print "(4(es12.5,4x))", t, u, v, w - end if + if (myid == 0) then + print "(4(es12.5,4x))", t, u, v, w + end if end if if (nout > 0) then - ! get left end point for output - call ExchangeBCOnly(sunvec_y) - - ! get vector data array - ydata => FN_VGetArrayPointer(sunvec_y) - - ! output the times to disk - if (myid == 0) then - write(100,"(es23.16)") t - end if - - ! output results to disk - do i = 1, Npts - idx = (i - 1) * Nvar - write(101, "(es23.16)", advance="no") ydata(idx + 1) - write(102, "(es23.16)", advance="no") ydata(idx + 2) - write(103, "(es23.16)", advance="no") ydata(idx + 3) - end do - - ! we have one extra output because of the periodic BCs - if (myid == nprocs - 1) then - write(101,"(es23.16)") Erecv(1) - write(102,"(es23.16)") Erecv(2) - write(103,"(es23.16)") Erecv(3) - else - write(101,"(es23.16)") - write(102,"(es23.16)") - write(103,"(es23.16)") - end if + ! get left end point for output + call ExchangeBCOnly(sunvec_y) + + ! get vector data array + ydata => FN_VGetArrayPointer(sunvec_y) + + ! output the times to disk + if (myid == 0) then + write (100, "(es23.16)") t + end if + + ! output results to disk + do i = 1, Npts + idx = (i - 1)*Nvar + write (101, "(es23.16)", advance="no") ydata(idx + 1) + write (102, "(es23.16)", advance="no") ydata(idx + 2) + write (103, "(es23.16)", advance="no") ydata(idx + 3) + end do + + ! we have one extra output because of the periodic BCs + if (myid == nprocs - 1) then + write (101, "(es23.16)") Erecv(1) + write (102, "(es23.16)") Erecv(2) + write (103, "(es23.16)") Erecv(3) + else + write (101, "(es23.16)") + write (102, "(es23.16)") + write (103, "(es23.16)") + end if end if end subroutine WriteOutput - ! Initial Condition Function subroutine SetIC(sunvec_y) @@ -1740,37 +1721,35 @@ subroutine SetIC(sunvec_y) ydata => FN_VGetArrayPointer(sunvec_y) ! Steady state solution - us = k1 * A / k4 - vs = k2 * k4 * B / (k1 * k3 * A) + us = k1*A/k4 + vs = k2*k4*B/(k1*k3*A) ws = 3.0d0 ! Perturbation parameters - mu = xmax / 2.0d0 - sigma = xmax / 4.0d0 + mu = xmax/2.0d0 + sigma = xmax/4.0d0 alpha = 0.1d0 ! Gaussian perturbation - do j = 1,Npts + do j = 1, Npts - x = (myid * Npts + (j - 1)) * dx - p = alpha * exp( -((x - mu) * (x - mu)) / (2.0d0 * sigma * sigma) ) + x = (myid*Npts + (j - 1))*dx + p = alpha*exp(-((x - mu)*(x - mu))/(2.0d0*sigma*sigma)) - idx = (j - 1) * Nvar + idx = (j - 1)*Nvar - ydata(idx + 1) = us + p - ydata(idx + 2) = vs + p - ydata(idx + 3) = ws + p + ydata(idx + 1) = us + p + ydata(idx + 2) = vs + p + ydata(idx + 3) = ws + p end do end subroutine SetIC - ! -------------------------------------------------------------- ! Utility functions ! -------------------------------------------------------------- - ! Exchanges the periodic BCs only by sending the first mesh node to the last ! processor. subroutine ExchangeBCOnly(sunvec_y) @@ -1779,7 +1758,7 @@ subroutine ExchangeBCOnly(sunvec_y) use, intrinsic :: iso_c_binding use fsundials_core_mod - use ode_mod, only : Nvar, comm, myid, nprocs, Erecv, Wsend + use ode_mod, only: Nvar, comm, myid, nprocs, Erecv, Wsend !======= Declarations ========= implicit none @@ -1801,52 +1780,51 @@ subroutine ExchangeBCOnly(sunvec_y) ! first and last MPI task ID first = 0 - last = nprocs - 1 + last = nprocs - 1 ! Access data array from SUNDIALS vector ydata => FN_VGetArrayPointer(sunvec_y) ! open the East Irecv buffer if (myid == last) then - call MPI_Irecv(Erecv, nvar, MPI_DOUBLE_PRECISION, first, MPI_ANY_TAG, & - comm, reqR, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Irecv returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Irecv(Erecv, nvar, MPI_DOUBLE_PRECISION, first, MPI_ANY_TAG, & + comm, reqR, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Irecv returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if end if ! send first mesh node to the last processor if (myid == first) then - Wsend(1:Nvar) = ydata(1:Nvar) - call MPI_Isend(Wsend, nvar, MPI_DOUBLE, last, 0, & - comm, reqS, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Isend returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + Wsend(1:Nvar) = ydata(1:Nvar) + call MPI_Isend(Wsend, nvar, MPI_DOUBLE, last, 0, & + comm, reqS, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Isend returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if end if ! wait for exchange to finish if (myid == last) then - call MPI_Wait(reqR, stat, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Wait returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Wait(reqR, stat, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Wait returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if end if if (myid == first) then - call MPI_Wait(reqS, stat, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Wait returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Wait(reqS, stat, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Wait returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if end if end subroutine ExchangeBCOnly - ! Starts the exchange of the neighbor information subroutine ExchangeAllStart(sunvec_y) @@ -1854,8 +1832,8 @@ subroutine ExchangeAllStart(sunvec_y) use, intrinsic :: iso_c_binding use fsundials_core_mod - use ode_mod, only : Nvar, comm, myid, nprocs, reqS, reqR, Wrecv, Wsend, & - Erecv, Esend, Npts, c + use ode_mod, only: Nvar, comm, myid, nprocs, reqS, reqR, Wrecv, Wsend, & + Erecv, Esend, Npts, c !======= Declarations ========= implicit none @@ -1877,19 +1855,19 @@ subroutine ExchangeAllStart(sunvec_y) ! first and last MPI task ID first = 0 - last = nprocs - 1 + last = nprocs - 1 ! get the ID for the process to the West and East of this process if (myid == first) then - ipW = last + ipW = last else - ipW = myid - 1 + ipW = myid - 1 end if if (myid == last) then - ipE = first + ipE = first else - ipE = myid + 1 + ipE = myid + 1 end if ! Access data array from SUNDIALS vector @@ -1897,58 +1875,57 @@ subroutine ExchangeAllStart(sunvec_y) if (c > 0.0d0) then - ! Right moving flow uses backward difference. - ! Send from west to east (last processor sends to first) + ! Right moving flow uses backward difference. + ! Send from west to east (last processor sends to first) - call MPI_Irecv(Wrecv, nvar, MPI_DOUBLE_PRECISION, ipW, & - MPI_ANY_TAG, comm, reqR, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Irecv returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Irecv(Wrecv, nvar, MPI_DOUBLE_PRECISION, ipW, & + MPI_ANY_TAG, comm, reqR, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Irecv returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if - Esend(1:Nvar) = ydata(Nvar * Npts - 2 : Nvar * Npts) + Esend(1:Nvar) = ydata(Nvar*Npts - 2:Nvar*Npts) - call MPI_Isend(Esend, nvar, MPI_DOUBLE_PRECISION, ipE, & - 0, comm, reqS, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Isend returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Isend(Esend, nvar, MPI_DOUBLE_PRECISION, ipE, & + 0, comm, reqS, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Isend returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if else if (c < 0.0d0) then - ! Left moving flow uses forward difference. - ! Send from east to west (first processor sends to last) + ! Left moving flow uses forward difference. + ! Send from east to west (first processor sends to last) - call MPI_Irecv(Erecv, nvar, MPI_DOUBLE_PRECISION, ipE, & - MPI_ANY_TAG, comm, reqR, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Irecv returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Irecv(Erecv, nvar, MPI_DOUBLE_PRECISION, ipE, & + MPI_ANY_TAG, comm, reqR, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Irecv returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if - Wsend(1:Nvar) = ydata(1:Nvar) + Wsend(1:Nvar) = ydata(1:Nvar) - call MPI_Isend(Wsend, nvar, MPI_DOUBLE_PRECISION, ipW, & - 0, comm, reqS, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Isend returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Isend(Wsend, nvar, MPI_DOUBLE_PRECISION, ipW, & + 0, comm, reqS, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Isend returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if end if end subroutine ExchangeAllStart - ! Completes the exchange of the neighbor information subroutine ExchangeAllEnd() !======= Inclusions =========== use, intrinsic :: iso_c_binding - use ode_mod, only : comm, reqS, reqR, c + use ode_mod, only: comm, reqS, reqR, c !======= Declarations ========= implicit none @@ -1963,22 +1940,21 @@ subroutine ExchangeAllEnd() ! wait for exchange to finish if (c < 0.0d0 .or. c > 0.0d0) then - call MPI_Wait(reqR, stat, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Wait returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if - - call MPI_Wait(reqS, stat, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error: MPI_Wait returned ",ierr - call MPI_Abort(comm, 1, ierr) - end if + call MPI_Wait(reqR, stat, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Wait returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if + + call MPI_Wait(reqS, stat, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error: MPI_Wait returned ", ierr + call MPI_Abort(comm, 1, ierr) + end if end if end subroutine ExchangeAllEnd - subroutine SetupProblem() !======= Inclusions =========== @@ -2010,171 +1986,171 @@ subroutine SetupProblem() ! MPI variables call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - print *, "Error:MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + print *, "Error:MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if call MPI_Comm_size(comm, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - print *, "Error:MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + print *, "Error:MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! default problem setting - Nx = 100 - Npts = Nx / nprocs - Neq = Nvar * Npts + Nx = 100 + Npts = Nx/nprocs + Neq = Nvar*Npts xmax = 1.0d0 - dx = xmax / Nx + dx = xmax/Nx ! Problem parameters - c = 0.01d0 - A = 1.0d0 - B = 3.5d0 + c = 0.01d0 + A = 1.0d0 + B = 3.5d0 k1 = 1.0d0 k2 = 1.0d0 k3 = 1.0d0 k4 = 1.0d0 - k5 = 1.0d0 / 5.0d-6 - k6 = 1.0d0 / 5.0d-6 + k5 = 1.0d0/5.0d-6 + k6 = 1.0d0/5.0d-6 ! Set default integrator options - order = 3 - rtol = 1.0d-6 - atol = 1.0d-9 - t0 = 0.0d0 - tf = 10.0d0 - explicit = .false. - global = .false. - fused = .false. - monitor = .false. + order = 3 + rtol = 1.0d-6 + atol = 1.0d-9 + t0 = 0.0d0 + tf = 10.0d0 + explicit = .false. + global = .false. + fused = .false. + monitor = .false. printtime = .false. - nout = 40 + nout = 40 ! check for input args nargs = command_argument_count() - argj= 1 + argj = 1 do while (argj <= nargs) - ! get input arg - call get_command_argument(argj, arg, length, status) - - ! check if reading the input was successful - if (status == -1) then - print *, "ERROR: Command line input too long (max length = 32)" - call MPI_Abort(comm, 1, ierr) - end if - - ! check if there are no more inputs to read - if (len_trim(arg) == 0) exit - - ! check for valid input options - if (trim(arg) == "--monitor") then - monitor = .true. - else if (trim(arg) == "--printtime") then - printtime = .true. - else if (trim(arg) == "--nout") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) nout - else if (trim(arg) == "--nx") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) Nx - else if (trim(arg) == "--xmax") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) xmax - else if (trim(arg) == "--A") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) A - else if (trim(arg) == "--B") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) B - else if (trim(arg) == "--k") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) k1 - read(arg,*) k2 - read(arg,*) k3 - read(arg,*) k4 - else if (trim(arg) == "--c") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) c - else if (trim(arg) == "--order") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) order - else if (trim(arg) == "--explicit") then - explicit = .true. - else if (trim(arg) == "--global-nls") then - global = .true. - else if (trim(arg) == "--fused") then - fused = .true. - else if (trim(arg) == "--tf") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) tf - else if (trim(arg) == "--rtol") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) rtol - else if (trim(arg) == "--atol") then - argj = argj + 1 - call get_command_argument(argj, arg) - read(arg,*) atol - else if (trim(arg) == "--help") then - if (myid == 0) call InputHelp() - call MPI_Abort(comm, 1, ierr) - else - if (myid == 0) then - print *, "Error: Unknown command line input ",trim(arg) - call InputHelp() - end if - call MPI_Abort(comm, 1, ierr) - end if - - ! move to the next input - argj = argj+1 + ! get input arg + call get_command_argument(argj, arg, length, status) + + ! check if reading the input was successful + if (status == -1) then + print *, "ERROR: Command line input too long (max length = 32)" + call MPI_Abort(comm, 1, ierr) + end if + + ! check if there are no more inputs to read + if (len_trim(arg) == 0) exit + + ! check for valid input options + if (trim(arg) == "--monitor") then + monitor = .true. + else if (trim(arg) == "--printtime") then + printtime = .true. + else if (trim(arg) == "--nout") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) nout + else if (trim(arg) == "--nx") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) Nx + else if (trim(arg) == "--xmax") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) xmax + else if (trim(arg) == "--A") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) A + else if (trim(arg) == "--B") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) B + else if (trim(arg) == "--k") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) k1 + read (arg, *) k2 + read (arg, *) k3 + read (arg, *) k4 + else if (trim(arg) == "--c") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) c + else if (trim(arg) == "--order") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) order + else if (trim(arg) == "--explicit") then + explicit = .true. + else if (trim(arg) == "--global-nls") then + global = .true. + else if (trim(arg) == "--fused") then + fused = .true. + else if (trim(arg) == "--tf") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) tf + else if (trim(arg) == "--rtol") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) rtol + else if (trim(arg) == "--atol") then + argj = argj + 1 + call get_command_argument(argj, arg) + read (arg, *) atol + else if (trim(arg) == "--help") then + if (myid == 0) call InputHelp() + call MPI_Abort(comm, 1, ierr) + else + if (myid == 0) then + print *, "Error: Unknown command line input ", trim(arg) + call InputHelp() + end if + call MPI_Abort(comm, 1, ierr) + end if + + ! move to the next input + argj = argj + 1 end do ! Setup the parallel decomposition - if (MOD(Nx,int(nprocs, myindextype)) > 0) then - print *, "ERROR: The mesh size (nx = ", Nx,") must be divisible by the number of processors (",nprocs,")" - call MPI_Abort(comm, 1, ierr) + if (MOD(Nx, int(nprocs, myindextype)) > 0) then + print *, "ERROR: The mesh size (nx = ", Nx, ") must be divisible by the number of processors (", nprocs, ")" + call MPI_Abort(comm, 1, ierr) end if - Npts = Nx / nprocs - Neq = nvar * Npts - dx = xmax / Nx ! Nx is number of intervals + Npts = Nx/nprocs + Neq = nvar*Npts + dx = xmax/Nx ! Nx is number of intervals ! Create the solution masks umask_s => FN_VNew_Serial(Neq, sunctx) - umask => FN_VMake_MPIPlusX(comm, umask_s, sunctx) + umask => FN_VMake_MPIPlusX(comm, umask_s, sunctx) if (fused) then - retval = FN_VEnableFusedOps_Serial(umask_s, SUNTRUE) - if (retval /= 0) then - print *, "Error: FN_VEnableFusedOps_Serial returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FN_VEnableFusedOps_MPIManyVector(umask, SUNTRUE) - if (retval /= 0) then - print *, "Error: FN_VEnableFusedOps_MPIManyVector returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FN_VEnableFusedOps_Serial(umask_s, SUNTRUE) + if (retval /= 0) then + print *, "Error: FN_VEnableFusedOps_Serial returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FN_VEnableFusedOps_MPIManyVector(umask, SUNTRUE) + if (retval /= 0) then + print *, "Error: FN_VEnableFusedOps_MPIManyVector returned ", retval + call MPI_Abort(comm, 1, ierr) + end if end if call FN_VConst(0.0d0, umask) data => FN_VGetArrayPointer(umask) do j = 1, Npts - data(1 + (j - 1) * nvar) = 1.0d0 + data(1 + (j - 1)*nvar) = 1.0d0 end do vmask => FN_VClone(umask) @@ -2182,7 +2158,7 @@ subroutine SetupProblem() call FN_VConst(0.0d0, vmask) data => FN_VGetArrayPointer(vmask) do j = 1, Npts - data(2 + (j - 1) * nvar) = 1.0d0 + data(2 + (j - 1)*nvar) = 1.0d0 end do wmask => FN_VClone(umask) @@ -2190,68 +2166,67 @@ subroutine SetupProblem() call FN_VConst(0.0d0, wmask) data => FN_VGetArrayPointer(wmask) do j = 1, Npts - data(3 + (j - 1) * nvar) = 1.0d0 + data(3 + (j - 1)*nvar) = 1.0d0 end do ! Open output files for results if (nout > 0) then - if (myid == 0) then - write(outname, "(A,I0.6,A)") "t.",myid,".txt" - open(100, file=trim(outname)) - end if + if (myid == 0) then + write (outname, "(A,I0.6,A)") "t.", myid, ".txt" + open (100, file=trim(outname)) + end if - write(outname, "(A,I0.6,A)") "u.",myid,".txt" - open(101, file=trim(outname)) + write (outname, "(A,I0.6,A)") "u.", myid, ".txt" + open (101, file=trim(outname)) - write(outname, "(A,I0.6,A)") "v.",myid,".txt" - open(102, file=trim(outname)) + write (outname, "(A,I0.6,A)") "v.", myid, ".txt" + open (102, file=trim(outname)) - write(outname, "(A,I0.6,A)") "w.",myid,".txt" - open(103, file=trim(outname)) + write (outname, "(A,I0.6,A)") "w.", myid, ".txt" + open (103, file=trim(outname)) end if ! Print problem setup if (myid == 0) then - print "(A)" , "1D Advection-Reaction Test Problem" - print "(A,i0)" , "Number of Processors = ", nprocs - print "(A)" , "Mesh Info:" - print "(A,i0)" , " Nx = ",nx - print "(A,i0)" , " Npts = ",Npts - print "(A,es12.5)", " xmax = ",xmax - print "(A,es12.5)", " dx = ",dx - print "(A)" , "Problem Parameters:" - print "(A,es12.5)", " A = ",A - print "(A,es12.5)", " B = ",B - print "(A,es12.5)", " k = ",k1 - print "(A,es12.5)", " c = ",c - print "(A)" , "Integrator Options:" - print "(A,es12.5)", " t0 = ", t0 - print "(A,es12.5)", " tf = ", tf - print "(A,es12.5)", " reltol = ", rtol - print "(A,es12.5)", " abstol = ", atol - print "(A,i0)" , " order = ", order - print "(A,L1)" , " explicit = ", explicit - print "(A,L1)" , " fused ops = ", fused - if (.not. explicit) then - print "(A,L1)"," global NLS = ", global - end if - print "(A,i0)" , " nout = ", nout + print "(A)", "1D Advection-Reaction Test Problem" + print "(A,i0)", "Number of Processors = ", nprocs + print "(A)", "Mesh Info:" + print "(A,i0)", " Nx = ", nx + print "(A,i0)", " Npts = ", Npts + print "(A,es12.5)", " xmax = ", xmax + print "(A,es12.5)", " dx = ", dx + print "(A)", "Problem Parameters:" + print "(A,es12.5)", " A = ", A + print "(A,es12.5)", " B = ", B + print "(A,es12.5)", " k = ", k1 + print "(A,es12.5)", " c = ", c + print "(A)", "Integrator Options:" + print "(A,es12.5)", " t0 = ", t0 + print "(A,es12.5)", " tf = ", tf + print "(A,es12.5)", " reltol = ", rtol + print "(A,es12.5)", " abstol = ", atol + print "(A,i0)", " order = ", order + print "(A,L1)", " explicit = ", explicit + print "(A,L1)", " fused ops = ", fused + if (.not. explicit) then + print "(A,L1)", " global NLS = ", global + end if + print "(A,i0)", " nout = ", nout end if end subroutine SetupProblem - subroutine FreeProblem() !======= Inclusions =========== use, intrinsic :: iso_c_binding use fsundials_core_mod - use ode_mod, only : sunctx, logger, myid, nout, umask_s, umask, vmask, wmask + use ode_mod, only: sunctx, logger, myid, nout, umask_s, umask, vmask, wmask !======= Declarations ========= implicit none @@ -2267,18 +2242,17 @@ subroutine FreeProblem() ! close output streams if (nout > 0) then - if (myid == 0) close(100) - close(101) - close(102) - close(103) + if (myid == 0) close (100) + close (101) + close (102) + close (103) end if - ierr = FSUNLogger_Destroy(logger) - ierr = FSUNContext_Free(sunctx) + ierr = FSUNLogger_Destroy(logger) + ierr = FSUNContext_Free(sunctx) end subroutine FreeProblem - subroutine InputHelp() print *, "Command line options:" diff --git a/examples/arkode/F2003_parallel/ark_diag_kry_bbd_f2003.f90 b/examples/arkode/F2003_parallel/ark_diag_kry_bbd_f2003.f90 index c7b25afe86..8c67715974 100644 --- a/examples/arkode/F2003_parallel/ark_diag_kry_bbd_f2003.f90 +++ b/examples/arkode/F2003_parallel/ark_diag_kry_bbd_f2003.f90 @@ -51,8 +51,8 @@ module DiagkryData integer :: nprocs ! total number of MPI processes ! Problem parameters - integer(c_int), parameter :: iGStype = 1 - integer(c_int), parameter :: iPretype0 = 1 + integer(c_int), parameter :: iGStype = 1 + integer(c_int), parameter :: iPretype0 = 1 integer(c_int64_t), parameter :: nlocal = 10 integer(c_int64_t) :: neq, mu, ml, mudq, mldq integer(c_int) :: iPretype @@ -64,7 +64,7 @@ module DiagkryData ! ODE RHS function f(t,y). ! ---------------------------------------------------------------- integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & - result(retval) bind(C) + result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -76,7 +76,7 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(nlocal) :: y(:) @@ -88,15 +88,15 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & !======= Internals ============ ! Get data arrays from SUNDIALS vectors - y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) + y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) ydot(1:nlocal) => FN_VGetArrayPointer(sunvec_ydot) ! Initialize ydot to zero ydot = 0.d0 ! Fill ydot with rhs function - do i = 1,nlocal - ydot(i) = -alpha * (myid * nlocal + i) * y(i) + do i = 1, nlocal + ydot(i) = -alpha*(myid*nlocal + i)*y(i) end do retval = 0 ! Return with success @@ -108,7 +108,7 @@ end function frhs ! Local g function for BBD preconditioner (calls ODE RHS). ! ---------------------------------------------------------------- integer(c_int) function LocalgFn(nnlocal, t, sunvec_y, sunvec_g, user_data) & - result(retval) bind(C) + result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -121,15 +121,15 @@ integer(c_int) function LocalgFn(nnlocal, t, sunvec_y, sunvec_g, user_data) & integer(c_int64_t) :: nnlocal ! local space type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_g ! output g N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local data integer :: ierr ierr = frhs(t, sunvec_y, sunvec_g, user_data) if (ierr /= 0) then - write(0,*) "Error in LocalgFn user-defined function, ierr = ", ierr - stop 1 + write (0, *) "Error in LocalgFn user-defined function, ierr = ", ierr + stop 1 end if retval = 0 ! Return with success @@ -140,7 +140,6 @@ end function LocalgFn end module DiagkryData ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Main driver program ! ---------------------------------------------------------------- @@ -205,47 +204,47 @@ program driver ! initialize MPI call MPI_Init(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + write (0, *) "Error in MPI_Init = ", ierr + stop 1 end if call MPI_Comm_size(comm, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_size = ", ierr + call MPI_Abort(comm, 1, ierr) end if call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Set input arguments neq and alpha - neq = nprocs * nlocal + neq = nprocs*nlocal alpha = 10.0d0 ! Create SUNDIALS simulation context, now that comm has been configured retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNContext_Create returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Initial problem output outproc = (myid == 0) if (outproc) then - write(6,*) " " - write(6,*) "Diagonal test problem:"; - write(6,'(A,i4)') " neq = " , neq - write(6,'(A,i4)') " nlocal = " , nlocal - write(6,'(A,i4)') " nprocs = " , nprocs - write(6,'(A,es9.2)') " rtol = ", rtol - write(6,'(A,es9.2)') " atol = ", atol - write(6,'(A,es9.2)') " alpha = ", alpha - write(6,*) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" - write(6,*) " Method is DIRK/NEWTON/SPGMR" - write(6,*) " Precond is band-block-diagonal, using ARKBBDPRE" - write(6,*) " " - endif + write (6, *) " " + write (6, *) "Diagonal test problem:"; + write (6, '(A,i4)') " neq = ", neq + write (6, '(A,i4)') " nlocal = ", nlocal + write (6, '(A,i4)') " nprocs = ", nprocs + write (6, '(A,es9.2)') " rtol = ", rtol + write (6, '(A,es9.2)') " atol = ", atol + write (6, '(A,es9.2)') " alpha = ", alpha + write (6, *) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" + write (6, *) " Method is DIRK/NEWTON/SPGMR" + write (6, *) " Precond is band-block-diagonal, using ARKBBDPRE" + write (6, *) " " + end if ! Create solution vector, point at its data, and set initial condition sunvec_y => FN_VNew_Parallel(comm, nlocal, neq, sunctx) @@ -255,36 +254,36 @@ program driver ! Create the ARKStep timestepper module arkode_mem = FARKStepCreate(c_null_funptr, c_funloc(frhs), t0, sunvec_y, sunctx) if (.not. c_associated(arkode_mem)) then - print *, "Error: FARKStepCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKStepCreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Tell ARKODE to use a SPGMR linear solver. sunls => FSUNLinSol_SPGMR(sunvec_y, iPretype0, 0, sunctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - call MPI_Abort(comm, 1, ierr) + print *, 'ERROR: sunls = NULL' + call MPI_Abort(comm, 1, ierr) end if ! Attach the linear solver (with NULL SUNMatrix object) sunmat_A => null() retval = FARKodeSetLinearSolver(arkode_mem, sunls, sunmat_A) if (retval /= 0) then - print *, 'Error in FARKodeSetLinearSolver, retval = ', retval - call MPI_Abort(comm, 1, ierr) + print *, 'Error in FARKodeSetLinearSolver, retval = ', retval + call MPI_Abort(comm, 1, ierr) end if retval = FSUNLinSol_SPGMRSetGSType(sunls, iGStype) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval - call MPI_Abort(comm, 1, ierr) + print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FARKodeSStolerances(arkode_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FARKodeSStolerances returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Initialize BBD preconditioner @@ -293,218 +292,218 @@ program driver mudq = 0 mldq = 0 retval = FARKBBDPrecInit(arkode_mem, nlocal, mudq, mldq, mu, ml, 0.d0, & - c_funloc(LocalgFn), c_null_funptr) + c_funloc(LocalgFn), c_null_funptr) if (retval /= 0) then - print *, "Error: FARKBBDPrecInit returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKBBDPrecInit returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Run problem twice, using differing preconditioning types each time - do iPretype = 1,2 - - if (iPretype == 2) then - - y = 1.d0 - retval = FARKStepReInit(arkode_mem, c_null_funptr, c_funloc(frhs), & - t0, sunvec_y) - if (retval /= 0) then - print *, "Error in FARKStepReInit, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FARKBBDPrecReInit(arkode_mem, mudq, mldq, 0.d0) - if (retval /= 0) then - print *, "Error in FARKBBDPrecReInit, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FSUNLinSol_SPGMRSetPrecType(sunls, iPretype) - if (retval /= 0) then - print *, "Error in FSUNLinSol_SPGMRSetPrecType, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - if (outproc) write(6,*) " Preconditioning on right:" - - end if - - if (iPretype == 1 .and. outproc) write(6,*) " Preconditioning on left:" - - ! Main time-stepping loop: calls FARKodeEvolve to perform the integration, - ! then prints results. Stops when the final time has been reached - t(1) = T0 - dTout = 0.1d0 - tout = T0+dTout - if (outproc) then - write(6,*) " t steps steps att. fe fi" - write(6,*) " -------------------------------------------------" - end if - do ioutput=1,Nt - - ! Integrate to output time - retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) - if (retval /= 0) then - print *, "Error: FARKodeEvolve returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Retrieve solver statistics - retval = FARKodeGetNumSteps(arkode_mem, nst) - if (retval /= 0) then - print *, "Error: FARKodeGetNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) - if (retval /= 0) then - print *, "Error: FARKodeGetNumStepAttempts returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) - if (retval /= 0) then - print *, "Error: FARKStepGetNumRhsEvals returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! print solution stats and update internal time - if (outproc) write(6,'(3x,f10.6,4(3x,i6))') t, nst, nst_a, nfe, nfi - tout = min(tout + dTout, Tf) - - end do - if (outproc) then - write(6,*) " -------------------------------------------------" - end if - - ! Get max. absolute error in the local vector. - errmax = 0.d0 - do i = 1,nlocal - erri = y(i) - exp(-alpha * (myid * nlocal + i) * t(1)) - errmax = max(errmax, abs(erri)) - end do - - ! Get global max. error from MPI_Reduce call. - call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & - 0, comm, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error in MPI_Reduce = ", ierr - call MPI_Abort(comm, 1, ierr) - end if + do iPretype = 1, 2 - ! Print global max. error - if (outproc) print '(a,es10.2)', "Max. absolute error is ", gerrmax + if (iPretype == 2) then - ! Get final statistics - retval = FARKodeGetNumSteps(arkode_mem, nst) - if (retval /= 0) then - print *, "Error: FARKodeGetNumSteps returned ",retval + y = 1.d0 + retval = FARKStepReInit(arkode_mem, c_null_funptr, c_funloc(frhs), & + t0, sunvec_y) + if (retval /= 0) then + print *, "Error in FARKStepReInit, retval = ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) - if (retval /= 0) then - print *, "Error: FARKodeGetNumStepAttempts returned ", retval + retval = FARKBBDPrecReInit(arkode_mem, mudq, mldq, 0.d0) + if (retval /= 0) then + print *, "Error in FARKBBDPrecReInit, retval = ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) - if (retval /= 0) then - print *, "Error: FARKStepGetNumRhsEvals returned ", retval + retval = FSUNLinSol_SPGMRSetPrecType(sunls, iPretype) + if (retval /= 0) then + print *, "Error in FSUNLinSol_SPGMRSetPrecType, retval = ", retval call MPI_Abort(comm, 1, ierr) - end if + end if + + if (outproc) write (6, *) " Preconditioning on right:" - retval = FARKodeGetNumPrecEvals(arkode_mem, npre) - if (retval /= 0) then - print *, "Error: FARKodeGetNumPrecEvals returned ", retval + end if + + if (iPretype == 1 .and. outproc) write (6, *) " Preconditioning on left:" + + ! Main time-stepping loop: calls FARKodeEvolve to perform the integration, + ! then prints results. Stops when the final time has been reached + t(1) = T0 + dTout = 0.1d0 + tout = T0 + dTout + if (outproc) then + write (6, *) " t steps steps att. fe fi" + write (6, *) " -------------------------------------------------" + end if + do ioutput = 1, Nt + + ! Integrate to output time + retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) + if (retval /= 0) then + print *, "Error: FARKodeEvolve returned ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FARKodeGetNumPrecSolves(arkode_mem, npsol) - if (retval /= 0) then - print *, "Error: FARKodeGetNumPrecSolves returned ", retval + ! Retrieve solver statistics + retval = FARKodeGetNumSteps(arkode_mem, nst) + if (retval /= 0) then + print *, "Error: FARKodeGetNumSteps returned ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FARKodeGetNumNonlinSolvIters(arkode_mem, nni) - if (retval /= 0) then - print *, "Error: FARKodeGetNumNonlinSolvIters returned ", retval + retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) + if (retval /= 0) then + print *, "Error: FARKodeGetNumStepAttempts returned ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FARKodeGetNumLinIters(arkode_mem, nli) - if (retval /= 0) then - print *, "Error: FARKodeGetNumLinIters returned ", retval + retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) + if (retval /= 0) then + print *, "Error: FARKStepGetNumRhsEvals returned ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - avdim = dble(nli) / dble(nni) + ! print solution stats and update internal time + if (outproc) write (6, '(3x,f10.6,4(3x,i6))') t, nst, nst_a, nfe, nfi + tout = min(tout + dTout, Tf) - retval = FARKodeGetNumNonlinSolvConvFails(arkode_mem, ncfn) - if (retval /= 0) then - print *, "Error: FARKodeGetNumNonlinSolvConvFails returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + end do + if (outproc) then + write (6, *) " -------------------------------------------------" + end if - retval = FARKodeGetNumLinConvFails(arkode_mem, ncfl) - if (retval /= 0) then - print *, "Error: FARKodeGetNumLinSolvConvFails returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + ! Get max. absolute error in the local vector. + errmax = 0.d0 + do i = 1, nlocal + erri = y(i) - exp(-alpha*(myid*nlocal + i)*t(1)) + errmax = max(errmax, abs(erri)) + end do - retval = FARKodeGetNumErrTestFails(arkode_mem, netf) - if (retval /= 0) then - print *, "Error: FARKodeGetNumErrTestFails returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + ! Get global max. error from MPI_Reduce call. + call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & + 0, comm, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error in MPI_Reduce = ", ierr + call MPI_Abort(comm, 1, ierr) + end if - retval = FARKodeGetWorkSpace(arkode_mem, lenrw, leniw) - if (retval /= 0) then - print *, "Error: FARKodeGetWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + ! Print global max. error + if (outproc) print '(a,es10.2)', "Max. absolute error is ", gerrmax - retval = FARKodeGetLinWorkSpace(arkode_mem, lenrwls, leniwls) - if (retval /= 0) then - print *, "Error: FARKodeGetLinWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + ! Get final statistics + retval = FARKodeGetNumSteps(arkode_mem, nst) + if (retval /= 0) then + print *, "Error: FARKodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - retval = FARKBBDPrecGetWorkSpace(arkode_mem, lenrwbbd, leniwbbd) - if (retval /= 0) then - print *, "Error: FARKBBDPrecGetWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) + if (retval /= 0) then + print *, "Error: FARKodeGetNumStepAttempts returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - retval = FARKBBDPrecGetNumGfnEvals(arkode_mem, ngebbd) - if (retval /= 0) then - print *, "Error: FARKBBDPrecGetNumGfnEvals returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Print some final statistics - if (outproc) then - write(6,*) " " - write(6,*) "Final Solver Statistics:" - write(6,'(2(A,i6),A)') " Internal solver steps = ", nst, & - " (attempted = ", nst_a, ")" - write(6,'(A,i6)') " Total explicit RHS evals = ", nfe - write(6,'(A,i6)') " Total implicit RHS evals = ", nfi - write(6,'(A,i6)') " Total preconditioner setups = ", npre - write(6,'(A,i6)') " Total preconditioner solves = ", npsol - write(6,'(A,i6)') " Total nonlinear iterations = ", nni - write(6,'(A,i6)') " Total linear iterations = ", nli - write(6,'(A,f8.4)') " Average Krylov subspace dimension = ", avdim - write(6,'(A,i6)') " Total Convergence Failures - Nonlinear = ", ncfn - write(6,'(A,i6)') " - Linear = ", ncfl - write(6,'(A,i6)') " Total number of error test failures = ", netf - write(6,'(A,2i6)') " Main solver real/int workspace sizes = ", lenrw, leniw - write(6,'(A,2i6)') " Linear solver real/int workspace sizes = ", lenrwls, leniwls - write(6,'(A,2i6)') " BBD preconditioner real/int workspace sizes = ", lenrwbbd, leniwbbd - write(6,'(A,i6)') " Total number of g evals = ", ngebbd - write(6,'(A)') " " - write(6,'(A)') " " - write(6,'(A)') " " - end if + retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) + if (retval /= 0) then + print *, "Error: FARKStepGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumPrecEvals(arkode_mem, npre) + if (retval /= 0) then + print *, "Error: FARKodeGetNumPrecEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumPrecSolves(arkode_mem, npsol) + if (retval /= 0) then + print *, "Error: FARKodeGetNumPrecSolves returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumNonlinSolvIters(arkode_mem, nni) + if (retval /= 0) then + print *, "Error: FARKodeGetNumNonlinSolvIters returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumLinIters(arkode_mem, nli) + if (retval /= 0) then + print *, "Error: FARKodeGetNumLinIters returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + avdim = dble(nli)/dble(nni) + + retval = FARKodeGetNumNonlinSolvConvFails(arkode_mem, ncfn) + if (retval /= 0) then + print *, "Error: FARKodeGetNumNonlinSolvConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumLinConvFails(arkode_mem, ncfl) + if (retval /= 0) then + print *, "Error: FARKodeGetNumLinSolvConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumErrTestFails(arkode_mem, netf) + if (retval /= 0) then + print *, "Error: FARKodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetWorkSpace(arkode_mem, lenrw, leniw) + if (retval /= 0) then + print *, "Error: FARKodeGetWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetLinWorkSpace(arkode_mem, lenrwls, leniwls) + if (retval /= 0) then + print *, "Error: FARKodeGetLinWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKBBDPrecGetWorkSpace(arkode_mem, lenrwbbd, leniwbbd) + if (retval /= 0) then + print *, "Error: FARKBBDPrecGetWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKBBDPrecGetNumGfnEvals(arkode_mem, ngebbd) + if (retval /= 0) then + print *, "Error: FARKBBDPrecGetNumGfnEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Print some final statistics + if (outproc) then + write (6, *) " " + write (6, *) "Final Solver Statistics:" + write (6, '(2(A,i6),A)') " Internal solver steps = ", nst, & + " (attempted = ", nst_a, ")" + write (6, '(A,i6)') " Total explicit RHS evals = ", nfe + write (6, '(A,i6)') " Total implicit RHS evals = ", nfi + write (6, '(A,i6)') " Total preconditioner setups = ", npre + write (6, '(A,i6)') " Total preconditioner solves = ", npsol + write (6, '(A,i6)') " Total nonlinear iterations = ", nni + write (6, '(A,i6)') " Total linear iterations = ", nli + write (6, '(A,f8.4)') " Average Krylov subspace dimension = ", avdim + write (6, '(A,i6)') " Total Convergence Failures - Nonlinear = ", ncfn + write (6, '(A,i6)') " - Linear = ", ncfl + write (6, '(A,i6)') " Total number of error test failures = ", netf + write (6, '(A,2i6)') " Main solver real/int workspace sizes = ", lenrw, leniw + write (6, '(A,2i6)') " Linear solver real/int workspace sizes = ", lenrwls, leniwls + write (6, '(A,2i6)') " BBD preconditioner real/int workspace sizes = ", lenrwbbd, leniwbbd + write (6, '(A,i6)') " Total number of g evals = ", ngebbd + write (6, '(A)') " " + write (6, '(A)') " " + write (6, '(A)') " " + end if end do ! Clean up and return with successful completion diff --git a/examples/arkode/F2003_parallel/ark_diag_non_f2003.f90 b/examples/arkode/F2003_parallel/ark_diag_non_f2003.f90 index e05da275b0..d3bfc3a55f 100644 --- a/examples/arkode/F2003_parallel/ark_diag_non_f2003.f90 +++ b/examples/arkode/F2003_parallel/ark_diag_non_f2003.f90 @@ -52,13 +52,11 @@ module DiagnonData contains - - !----------------------------------------------------------------- ! ODE RHS function f(t,y). !----------------------------------------------------------------- integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & - result(retval) bind(C) + result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -70,7 +68,7 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(nlocal) :: y(:) @@ -82,15 +80,15 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & !======= Internals ============ ! Get data arrays from SUNDIALS vectors - y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) + y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) ydot(1:nlocal) => FN_VGetArrayPointer(sunvec_ydot) ! Initialize ydot to zero ydot = 0.d0 ! Fill ydot with rhs function - do i = 1,nlocal - ydot(i) = -alpha * (myid * nlocal + i) * y(i) + do i = 1, nlocal + ydot(i) = -alpha*(myid*nlocal + i)*y(i) end do retval = 0 ! Return with success @@ -98,11 +96,9 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & end function frhs !----------------------------------------------------------------- - end module DiagnonData !------------------------------------------------------------------- - !------------------------------------------------------------------- ! Main driver program !------------------------------------------------------------------- @@ -149,45 +145,45 @@ program driver ! initialize MPI call MPI_Init(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + write (0, *) "Error in MPI_Init = ", ierr + stop 1 end if call MPI_Comm_size(comm, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_size = ", ierr + call MPI_Abort(comm, 1, ierr) end if call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Set input arguments neq and alpha - neq = nprocs * nlocal - alpha = 10.0d0 / neq + neq = nprocs*nlocal + alpha = 10.0d0/neq ! Create SUNDIALS simulation context, now that comm has been configured retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNContext_Create returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Initial problem output outproc = (myid == 0) if (outproc) then - write(6,*) " " - write(6,*) "Diagonal test problem:"; - write(6,'(A,i4)') " neq = " , neq - write(6,'(A,i4)') " nlocal = " , nlocal - write(6,'(A,i4)') " nprocs = " , nprocs - write(6,'(A,es9.2)') " rtol = ", rtol - write(6,'(A,es9.2)') " atol = ", atol - write(6,'(A,es9.2)') " alpha = ", alpha - write(6,*) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" - write(6,*) " " - endif + write (6, *) " " + write (6, *) "Diagonal test problem:"; + write (6, '(A,i4)') " neq = ", neq + write (6, '(A,i4)') " nlocal = ", nlocal + write (6, '(A,i4)') " nprocs = ", nprocs + write (6, '(A,es9.2)') " rtol = ", rtol + write (6, '(A,es9.2)') " atol = ", atol + write (6, '(A,es9.2)') " alpha = ", alpha + write (6, *) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" + write (6, *) " " + end if ! Create solution vector, point at its data, and set initial condition sunvec_y => FN_VNew_Parallel(comm, nlocal, neq, sunctx) @@ -197,15 +193,15 @@ program driver ! Create the ERKStep timestepper module arkode_mem = FERKStepCreate(c_funloc(frhs), t0, sunvec_y, sunctx) if (.not. c_associated(arkode_mem)) then - print *, "Error: FERKStepCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FERKStepCreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FARKodeSStolerances(arkode_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FARKodeSStolerances returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Main time-stepping loop: calls FARKodeEvolve to perform the @@ -213,60 +209,60 @@ program driver ! has been reached. t(1) = T0 dTout = 0.1d0 - tout = T0+dTout + tout = T0 + dTout if (outproc) then - write(6,*) " t steps steps att. fe" - write(6,*) " -----------------------------------------" + write (6, *) " t steps steps att. fe" + write (6, *) " -----------------------------------------" end if - do ioutput=1,Nt - - ! Integrate to output time - retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) - if (retval /= 0) then - print *, "Error: FARKodeEvolve returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FARKodeGetNumSteps(arkode_mem, nst) - if (retval /= 0) then - print *, "Error: FARKodeGetNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) - if (retval /= 0) then - print *, "Error: FARKodeGetNumStepAttempts returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FERKStepGetNumRhsEvals(arkode_mem, nfe) - if (retval /= 0) then - print *, "Error: FERKStepGetNumRhsEvals returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! print solution stats and update internal time - if (outproc) write(6,'(3x,f10.6,3(3x,i5))') t, nst, nst_a, nfe - tout = min(tout + dTout, Tf) + do ioutput = 1, Nt + + ! Integrate to output time + retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) + if (retval /= 0) then + print *, "Error: FARKodeEvolve returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumSteps(arkode_mem, nst) + if (retval /= 0) then + print *, "Error: FARKodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) + if (retval /= 0) then + print *, "Error: FARKodeGetNumStepAttempts returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FERKStepGetNumRhsEvals(arkode_mem, nfe) + if (retval /= 0) then + print *, "Error: FERKStepGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! print solution stats and update internal time + if (outproc) write (6, '(3x,f10.6,3(3x,i5))') t, nst, nst_a, nfe + tout = min(tout + dTout, Tf) end do if (outproc) then - write(6,*) " -----------------------------------------" + write (6, *) " -----------------------------------------" end if ! Get max. absolute error in the local vector. errmax = 0.d0 - do i = 1,nlocal - erri = y(i) - exp(-alpha * (myid * nlocal + i) * t(1)) - errmax = max(errmax, abs(erri)) + do i = 1, nlocal + erri = y(i) - exp(-alpha*(myid*nlocal + i)*t(1)) + errmax = max(errmax, abs(erri)) end do ! Get global max. error from MPI_Reduce call. call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & - 0, comm, ierr) + 0, comm, ierr) if (ierr /= MPI_SUCCESS) then - print *, "Error in MPI_Reduce = ", ierr - call MPI_Abort(comm, 1, ierr) + print *, "Error in MPI_Reduce = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Print global max. error @@ -275,37 +271,37 @@ program driver ! Get final statistics retval = FARKodeGetNumSteps(arkode_mem, nst) if (retval /= 0) then - print *, "Error: FARKodeGetNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (retval /= 0) then - print *, "Error: FARKodeGetNumStepAttempts returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumStepAttempts returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FERKStepGetNumRhsEvals(arkode_mem, nfe) if (retval /= 0) then - print *, "Error: FERKStepGetNumRhsEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FERKStepGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumErrTestFails(arkode_mem, netf) if (retval /= 0) then - print *, "Error: FARKodeGetNumErrTestFails returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Print some final statistics if (outproc) then - write(6,*) " " - write(6,*) "Final Solver Statistics:" - write(6,'(2(A,i6),A)') " Internal solver steps = ", nst, & - " (attempted = ", nst_a, ")" - write(6,'(A,i6)') " Total RHS evals = ", nfe - write(6,'(A,i6)') " Total number of error test failures = ", netf - endif + write (6, *) " " + write (6, *) "Final Solver Statistics:" + write (6, '(2(A,i6),A)') " Internal solver steps = ", nst, & + " (attempted = ", nst_a, ")" + write (6, '(A,i6)') " Total RHS evals = ", nfe + write (6, '(A,i6)') " Total number of error test failures = ", netf + end if ! Clean up and return with successful completion call FARKodeFree(arkode_mem) ! free integrator memory diff --git a/examples/arkode/F2003_parallel/ark_heat2D_f2003.f90 b/examples/arkode/F2003_parallel/ark_heat2D_f2003.f90 index e8c53d66cd..36e1d9e315 100644 --- a/examples/arkode/F2003_parallel/ark_heat2D_f2003.f90 +++ b/examples/arkode/F2003_parallel/ark_heat2D_f2003.f90 @@ -85,7 +85,7 @@ module Heat2DData integer, target :: comm ! communicator object integer :: myid ! MPI process ID integer :: nprocs ! total number of MPI processes - logical :: HaveNbor(2,2) ! flags denoting neighbor on boundary + logical :: HaveNbor(2, 2) ! flags denoting neighbor on boundary real(c_double), dimension(:), allocatable :: Erecv ! receive buffers for neighbor exchange real(c_double), dimension(:), allocatable :: Wrecv real(c_double), dimension(:), allocatable :: Nrecv @@ -98,10 +98,10 @@ module Heat2DData ! Problem parameters real(c_double) :: kx ! x-directional diffusion coefficient real(c_double) :: ky ! y-directional diffusion coefficient - real(c_double), dimension(:,:), allocatable :: h ! heat source vector + real(c_double), dimension(:, :), allocatable :: h ! heat source vector ! Preconditioning data - real(c_double), dimension(:,:), allocatable :: d ! inverse of Jacobian diagonal + real(c_double), dimension(:, :), allocatable :: d ! inverse of Jacobian diagonal contains @@ -122,24 +122,23 @@ subroutine InitHeat2DData() dy = 0.d0 kx = 0.d0 ky = 0.d0 - if (allocated(h)) deallocate(h) - if (allocated(d)) deallocate(d) + if (allocated(h)) deallocate (h) + if (allocated(d)) deallocate (d) comm = MPI_COMM_WORLD myid = 0 nprocs = 0 HaveNbor = .false. - if (allocated(Erecv)) deallocate(Erecv) - if (allocated(Wrecv)) deallocate(Wrecv) - if (allocated(Nrecv)) deallocate(Nrecv) - if (allocated(Srecv)) deallocate(Srecv) - if (allocated(Esend)) deallocate(Esend) - if (allocated(Wsend)) deallocate(Wsend) - if (allocated(Nsend)) deallocate(Nsend) - if (allocated(Ssend)) deallocate(Ssend) + if (allocated(Erecv)) deallocate (Erecv) + if (allocated(Wrecv)) deallocate (Wrecv) + if (allocated(Nrecv)) deallocate (Nrecv) + if (allocated(Srecv)) deallocate (Srecv) + if (allocated(Esend)) deallocate (Esend) + if (allocated(Wsend)) deallocate (Wsend) + if (allocated(Nsend)) deallocate (Nsend) + if (allocated(Ssend)) deallocate (Ssend) end subroutine InitHeat2DData ! -------------------------------------------------------------- - ! -------------------------------------------------------------- ! Set up parallel decomposition ! -------------------------------------------------------------- @@ -154,91 +153,90 @@ subroutine SetupDecomp(ierr) ! check that this has not been called before if (allocated(h) .or. allocated(d)) then - write(0,*) "SetupDecomp warning: parallel decomposition already set up" - ierr = 1 - return + write (0, *) "SetupDecomp warning: parallel decomposition already set up" + ierr = 1 + return end if ! get suggested parallel decomposition dims = (/0, 0/) call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = " , ierr - return + write (0, *) "Error in MPI_Comm_size = ", ierr + return end if call MPI_Dims_create(nprocs, 2, dims, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Dims_create = " , ierr - return + write (0, *) "Error in MPI_Dims_create = ", ierr + return end if ! set up 2D Cartesian communicator periods = (/0, 0/) call MPI_Cart_create(MPI_COMM_WORLD, 2, dims, periods, 0, comm, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_create = " , ierr - return + write (0, *) "Error in MPI_Cart_create = ", ierr + return end if call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = " , ierr - return + write (0, *) "Error in MPI_Comm_rank = ", ierr + return end if ! determine local extents call MPI_Cart_get(comm, 2, dims, periods, coords, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_get = " , ierr - return + write (0, *) "Error in MPI_Cart_get = ", ierr + return end if is = nx*coords(1)/dims(1) + 1 - ie = nx*(coords(1)+1)/dims(1) + ie = nx*(coords(1) + 1)/dims(1) js = ny*coords(2)/dims(2) + 1 - je = ny*(coords(2)+1)/dims(2) - nxl = ie-is+1 - nyl = je-js+1 + je = ny*(coords(2) + 1)/dims(2) + nxl = ie - is + 1 + nyl = je - js + 1 ! determine if I have neighbors, and allocate exchange buffers - HaveNbor(1,1) = (is /= 1) - HaveNbor(1,2) = (ie /= nx) - HaveNbor(2,1) = (js /= 1) - HaveNbor(2,2) = (je /= ny) - if (HaveNbor(1,1)) then - allocate(Wrecv(nyl)) - allocate(Wsend(nyl)) - endif - if (HaveNbor(1,2)) then - allocate(Erecv(nyl)) - allocate(Esend(nyl)) - endif - if (HaveNbor(2,1)) then - allocate(Srecv(nxl)) - allocate(Ssend(nxl)) - endif - if (HaveNbor(2,2)) then - allocate(Nrecv(nxl)) - allocate(Nsend(nxl)) - endif + HaveNbor(1, 1) = (is /= 1) + HaveNbor(1, 2) = (ie /= nx) + HaveNbor(2, 1) = (js /= 1) + HaveNbor(2, 2) = (je /= ny) + if (HaveNbor(1, 1)) then + allocate (Wrecv(nyl)) + allocate (Wsend(nyl)) + end if + if (HaveNbor(1, 2)) then + allocate (Erecv(nyl)) + allocate (Esend(nyl)) + end if + if (HaveNbor(2, 1)) then + allocate (Srecv(nxl)) + allocate (Ssend(nxl)) + end if + if (HaveNbor(2, 2)) then + allocate (Nrecv(nxl)) + allocate (Nsend(nxl)) + end if ! allocate temporary vectors - allocate(h(nxl,nyl)) ! Create vector for heat source - allocate(d(nxl,nyl)) ! Create vector for Jacobian diagonal + allocate (h(nxl, nyl)) ! Create vector for heat source + allocate (d(nxl, nyl)) ! Create vector for Jacobian diagonal ierr = 0 ! return with success flag return end subroutine SetupDecomp ! -------------------------------------------------------------- - ! -------------------------------------------------------------- ! Perform neighbor exchange ! -------------------------------------------------------------- subroutine Exchange(y, ierr) ! declarations implicit none - real(c_double), intent(in) :: y(nxl,nyl) + real(c_double), intent(in) :: y(nxl, nyl) integer, intent(out) :: ierr - integer :: reqSW, reqSE, reqSS, reqSN, reqRW, reqRE, reqRS, reqRN; + integer :: reqSW, reqSE, reqSS, reqSN, reqRW, reqRE, reqRS, reqRN; integer :: stat(MPI_STATUS_SIZE) integer :: i, ipW, ipE, ipS, ipN integer :: coords(2), dims(2), periods(2), nbcoords(2) @@ -248,194 +246,193 @@ subroutine Exchange(y, ierr) ! MPI neighborhood information call MPI_Cart_get(comm, 2, dims, periods, coords, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_get = ", ierr - return - endif - if (HaveNbor(1,1)) then - nbcoords = (/ coords(1)-1, coords(2) /) - call MPI_Cart_rank(comm, nbcoords, ipW, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - endif - endif - if (HaveNbor(1,2)) then - nbcoords = (/ coords(1)+1, coords(2) /) - call MPI_Cart_rank(comm, nbcoords, ipE, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - endif - endif - if (HaveNbor(2,1)) then - nbcoords = (/ coords(1), coords(2)-1 /) - call MPI_Cart_rank(comm, nbcoords, ipS, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - endif - endif - if (HaveNbor(2,2)) then - nbcoords = (/ coords(1), coords(2)+1 /) - call MPI_Cart_rank(comm, nbcoords, ipN, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - endif - endif + write (0, *) "Error in MPI_Cart_get = ", ierr + return + end if + if (HaveNbor(1, 1)) then + nbcoords = (/coords(1) - 1, coords(2)/) + call MPI_Cart_rank(comm, nbcoords, ipW, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if + end if + if (HaveNbor(1, 2)) then + nbcoords = (/coords(1) + 1, coords(2)/) + call MPI_Cart_rank(comm, nbcoords, ipE, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if + end if + if (HaveNbor(2, 1)) then + nbcoords = (/coords(1), coords(2) - 1/) + call MPI_Cart_rank(comm, nbcoords, ipS, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if + end if + if (HaveNbor(2, 2)) then + nbcoords = (/coords(1), coords(2) + 1/) + call MPI_Cart_rank(comm, nbcoords, ipN, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if + end if ! open Irecv buffers - if (HaveNbor(1,1)) then - call MPI_Irecv(Wrecv, nyl, MPI_DOUBLE_PRECISION, ipW, & - MPI_ANY_TAG, comm, reqRW, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - endif - endif - if (HaveNbor(1,2)) then - call MPI_Irecv(Erecv, nyl, MPI_DOUBLE_PRECISION, ipE, & - MPI_ANY_TAG, comm, reqRE, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - endif - endif - if (HaveNbor(2,1)) then - call MPI_Irecv(Srecv, nxl, MPI_DOUBLE_PRECISION, ipS, & - MPI_ANY_TAG, comm, reqRS, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - endif - endif - if (HaveNbor(2,2)) then - call MPI_Irecv(Nrecv, nxl, MPI_DOUBLE_PRECISION, ipN, & - MPI_ANY_TAG, comm, reqRN, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - endif - endif + if (HaveNbor(1, 1)) then + call MPI_Irecv(Wrecv, nyl, MPI_DOUBLE_PRECISION, ipW, & + MPI_ANY_TAG, comm, reqRW, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if + end if + if (HaveNbor(1, 2)) then + call MPI_Irecv(Erecv, nyl, MPI_DOUBLE_PRECISION, ipE, & + MPI_ANY_TAG, comm, reqRE, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if + end if + if (HaveNbor(2, 1)) then + call MPI_Irecv(Srecv, nxl, MPI_DOUBLE_PRECISION, ipS, & + MPI_ANY_TAG, comm, reqRS, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if + end if + if (HaveNbor(2, 2)) then + call MPI_Irecv(Nrecv, nxl, MPI_DOUBLE_PRECISION, ipN, & + MPI_ANY_TAG, comm, reqRN, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if + end if ! send data - if (HaveNbor(1,1)) then - do i=1,nyl - Wsend(i) = y(1,i) - enddo - call MPI_Isend(Wsend, nyl, MPI_DOUBLE_PRECISION, ipW, 0, & - comm, reqSW, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - endif - endif - if (HaveNbor(1,2)) then - do i=1,nyl - Esend(i) = y(nxl,i) - enddo - call MPI_Isend(Esend, nyl, MPI_DOUBLE_PRECISION, ipE, 1, & - comm, reqSE, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - endif - endif - if (HaveNbor(2,1)) then - do i=1,nxl - Ssend(i) = y(i,1) - enddo - call MPI_Isend(Ssend, nxl, MPI_DOUBLE_PRECISION, ipS, 2, & - comm, reqSS, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - endif - endif - if (HaveNbor(2,2)) then - do i=1,nxl - Nsend(i) = y(i,nyl) - enddo - call MPI_Isend(Nsend, nxl, MPI_DOUBLE_PRECISION, ipN, 3, & - comm, reqSN, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - endif - endif + if (HaveNbor(1, 1)) then + do i = 1, nyl + Wsend(i) = y(1, i) + end do + call MPI_Isend(Wsend, nyl, MPI_DOUBLE_PRECISION, ipW, 0, & + comm, reqSW, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if + end if + if (HaveNbor(1, 2)) then + do i = 1, nyl + Esend(i) = y(nxl, i) + end do + call MPI_Isend(Esend, nyl, MPI_DOUBLE_PRECISION, ipE, 1, & + comm, reqSE, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if + end if + if (HaveNbor(2, 1)) then + do i = 1, nxl + Ssend(i) = y(i, 1) + end do + call MPI_Isend(Ssend, nxl, MPI_DOUBLE_PRECISION, ipS, 2, & + comm, reqSS, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if + end if + if (HaveNbor(2, 2)) then + do i = 1, nxl + Nsend(i) = y(i, nyl) + end do + call MPI_Isend(Nsend, nxl, MPI_DOUBLE_PRECISION, ipN, 3, & + comm, reqSN, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if + end if ! wait for messages to finish - if (HaveNbor(1,1)) then - call MPI_Wait(reqRW, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - call MPI_Wait(reqSW, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - endif - if (HaveNbor(1,2)) then - call MPI_Wait(reqRE, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - call MPI_Wait(reqSE, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - endif - if (HaveNbor(2,1)) then - call MPI_Wait(reqRS, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - call MPI_Wait(reqSS, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - endif - if (HaveNbor(2,2)) then - call MPI_Wait(reqRN, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - call MPI_Wait(reqSN, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - endif - endif + if (HaveNbor(1, 1)) then + call MPI_Wait(reqRW, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSW, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + end if + if (HaveNbor(1, 2)) then + call MPI_Wait(reqRE, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSE, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + end if + if (HaveNbor(2, 1)) then + call MPI_Wait(reqRS, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSS, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + end if + if (HaveNbor(2, 2)) then + call MPI_Wait(reqRN, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSN, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + end if ierr = MPI_SUCCESS ! return with success flag return end subroutine Exchange ! -------------------------------------------------------------- - ! -------------------------------------------------------------- ! Free memory allocated within Userdata ! -------------------------------------------------------------- subroutine FreeHeat2DData(ierr) implicit none integer, intent(out) :: ierr - if (allocated(h)) deallocate(h) - if (allocated(d)) deallocate(d) - if (allocated(Wrecv)) deallocate(Wrecv) - if (allocated(Wsend)) deallocate(Wsend) - if (allocated(Erecv)) deallocate(Erecv) - if (allocated(Esend)) deallocate(Esend) - if (allocated(Srecv)) deallocate(Srecv) - if (allocated(Ssend)) deallocate(Ssend) - if (allocated(Nrecv)) deallocate(Nrecv) - if (allocated(Nsend)) deallocate(Nsend) + if (allocated(h)) deallocate (h) + if (allocated(d)) deallocate (d) + if (allocated(Wrecv)) deallocate (Wrecv) + if (allocated(Wsend)) deallocate (Wsend) + if (allocated(Erecv)) deallocate (Erecv) + if (allocated(Esend)) deallocate (Esend) + if (allocated(Srecv)) deallocate (Srecv) + if (allocated(Ssend)) deallocate (Ssend) + if (allocated(Nrecv)) deallocate (Nrecv) + if (allocated(Nsend)) deallocate (Nsend) ierr = 0 ! return with success flag return end subroutine FreeHeat2DData @@ -445,7 +442,7 @@ end subroutine FreeHeat2DData ! ODE RHS function f(t,y). ! ---------------------------------------------------------------- integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & - result(retval) bind(C) + result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -457,11 +454,11 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(nxl,nyl) :: y(:,:) - real(c_double), pointer, dimension(nxl,nyl) :: ydot(:,:) + real(c_double), pointer, dimension(nxl, nyl) :: y(:, :) + real(c_double), pointer, dimension(nxl, nyl) :: ydot(:, :) ! local data real(c_double) :: c1, c2, c3 @@ -470,8 +467,8 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & !======= Internals ============ ! Get data arrays from SUNDIALS vectors - y(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_y) - ydot(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_ydot) + y(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_y) + ydot(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_ydot) ! Initialize ydot to zero ydot = 0.d0 @@ -479,66 +476,66 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & ! Exchange boundary data with neighbors call Exchange(y, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in Exchange = " , ierr - retval = -1 - return + write (0, *) "Error in Exchange = ", ierr + retval = -1 + return end if ! iterate over subdomain interior, computing approximation to RHS c1 = kx/dx/dx c2 = ky/dy/dy c3 = -2.d0*(c1 + c2) - do j=2,nyl-1 - do i=2,nxl-1 - ydot(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j) - enddo - enddo + do j = 2, nyl - 1 + do i = 2, nxl - 1 + ydot(i, j) = c1*(y(i - 1, j) + y(i + 1, j)) + c2*(y(i, j - 1) + y(i, j + 1)) + c3*y(i, j) + end do + end do ! iterate over subdomain boundaries (if not at overall domain boundary) - if (HaveNbor(1,1)) then ! West face - i=1 - do j=2,nyl-1 - ydot(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j) - enddo - endif - if (HaveNbor(1,2)) then ! East face - i=nxl - do j=2,nyl-1 - ydot(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j) - enddo - endif - if (HaveNbor(2,1)) then ! South face - j=1 - do i=2,nxl-1 - ydot(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j) - enddo - endif - if (HaveNbor(2,2)) then ! West face - j=nyl - do i=2,nxl-1 - ydot(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j) - enddo - endif - if (HaveNbor(1,1) .and. HaveNbor(2,1)) then ! South-West corner - i=1 - j=1 - ydot(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j) - endif - if (HaveNbor(1,1) .and. HaveNbor(2,2)) then ! North-West corner - i=1 - j=nyl - ydot(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j) - endif - if (HaveNbor(1,2) .and. HaveNbor(2,1)) then ! South-East corner - i=nxl - j=1 - ydot(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j) - endif - if (HaveNbor(1,2) .and. HaveNbor(2,2)) then ! North-East corner - i=nxl - j=nyl - ydot(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j) - endif + if (HaveNbor(1, 1)) then ! West face + i = 1 + do j = 2, nyl - 1 + ydot(i, j) = c1*(Wrecv(j) + y(i + 1, j)) + c2*(y(i, j - 1) + y(i, j + 1)) + c3*y(i, j) + end do + end if + if (HaveNbor(1, 2)) then ! East face + i = nxl + do j = 2, nyl - 1 + ydot(i, j) = c1*(y(i - 1, j) + Erecv(j)) + c2*(y(i, j - 1) + y(i, j + 1)) + c3*y(i, j) + end do + end if + if (HaveNbor(2, 1)) then ! South face + j = 1 + do i = 2, nxl - 1 + ydot(i, j) = c1*(y(i - 1, j) + y(i + 1, j)) + c2*(Srecv(i) + y(i, j + 1)) + c3*y(i, j) + end do + end if + if (HaveNbor(2, 2)) then ! West face + j = nyl + do i = 2, nxl - 1 + ydot(i, j) = c1*(y(i - 1, j) + y(i + 1, j)) + c2*(y(i, j - 1) + Nrecv(i)) + c3*y(i, j) + end do + end if + if (HaveNbor(1, 1) .and. HaveNbor(2, 1)) then ! South-West corner + i = 1 + j = 1 + ydot(i, j) = c1*(Wrecv(j) + y(i + 1, j)) + c2*(Srecv(i) + y(i, j + 1)) + c3*y(i, j) + end if + if (HaveNbor(1, 1) .and. HaveNbor(2, 2)) then ! North-West corner + i = 1 + j = nyl + ydot(i, j) = c1*(Wrecv(j) + y(i + 1, j)) + c2*(y(i, j - 1) + Nrecv(i)) + c3*y(i, j) + end if + if (HaveNbor(1, 2) .and. HaveNbor(2, 1)) then ! South-East corner + i = nxl + j = 1 + ydot(i, j) = c1*(y(i - 1, j) + Erecv(j)) + c2*(Srecv(i) + y(i, j + 1)) + c3*y(i, j) + end if + if (HaveNbor(1, 2) .and. HaveNbor(2, 2)) then ! North-East corner + i = nxl + j = nyl + ydot(i, j) = c1*(y(i - 1, j) + Erecv(j)) + c2*(y(i, j - 1) + Nrecv(i)) + c3*y(i, j) + end if ydot = ydot + h ! add in heat source @@ -547,12 +544,11 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & end function frhs ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Preconditioner setup routine (fills inverse of Jacobian diagonal) ! ---------------------------------------------------------------- integer(c_int) function PSetup(t, sunvec_y, sunvec_ydot, jok, jcurPtr, & - gamma, user_data) result(ierr) bind(C) + gamma, user_data) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -567,7 +563,7 @@ integer(c_int) function PSetup(t, sunvec_y, sunvec_ydot, jok, jcurPtr, & integer(c_int), value :: jok ! flag to signal for Jacobian update integer(c_int) :: jcurPtr ! flag to singal Jacobian is current real(c_double), value :: gamma ! current gamma value - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local variables real(c_double) :: c @@ -588,12 +584,11 @@ integer(c_int) function PSetup(t, sunvec_y, sunvec_ydot, jok, jcurPtr, & end function PSetup ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Preconditioner solve routine ! ---------------------------------------------------------------- integer(c_int) function PSolve(t, sunvec_y, sunvec_ydot, sunvec_r, & - sunvec_z, gamma, delta, lr, user_data) result(ierr) bind(C) + sunvec_z, gamma, delta, lr, user_data) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -610,17 +605,17 @@ integer(c_int) function PSolve(t, sunvec_y, sunvec_ydot, sunvec_r, & real(c_double), value :: gamma ! current gamma value real(c_double), value :: delta ! current delta value integer(c_int), value :: lr ! left or right preconditioning - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(nxl,nyl) :: r(:,:) - real(c_double), pointer, dimension(nxl,nyl) :: z(:,:) + real(c_double), pointer, dimension(nxl, nyl) :: r(:, :) + real(c_double), pointer, dimension(nxl, nyl) :: z(:, :) !======= Internals ============ ! Get data arrays from SUNDIALS vectors - r(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_r) - z(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_z) + r(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_r) + z(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_z) ! perform Jacobi solve (whole array operation) z = r*d @@ -633,7 +628,6 @@ end function PSolve end module Heat2DData ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -667,9 +661,9 @@ program driver ! solution vector and other local variables type(N_Vector), pointer :: sunvec_y ! solution N_Vector type(N_Vector), pointer :: sunvec_ones ! masking vector for output - real(c_double), pointer, dimension(nxl,nyl) :: y(:,:) ! vector data + real(c_double), pointer, dimension(nxl, nyl) :: y(:, :) ! vector data type(SUNLinearSolver), pointer :: sun_LS ! linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(c_ptr) :: arkode_mem ! ARKODE memory integer(c_int64_t) :: N, Ntot integer(c_int) :: retval @@ -694,13 +688,13 @@ program driver ! initialize MPI call MPI_Init(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + write (0, *) "Error in MPI_Init = ", ierr + stop 1 end if call MPI_Comm_rank(MPI_COMM_WORLD, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Initialize Heat2DData module @@ -709,130 +703,130 @@ program driver ny = ny_ kx = kx_ ky = ky_ - dx = 1.d0/(nx-1) ! x mesh spacing - dy = 1.d0/(ny-1) ! x mesh spacing + dx = 1.d0/(nx - 1) ! x mesh spacing + dy = 1.d0/(ny - 1) ! x mesh spacing ! Set up parallel decomposition (computes local mesh sizes) call SetupDecomp(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in SetupDecomp = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in SetupDecomp = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Create SUNDIALS simulation context, now that comm has been configured retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNContext_Create returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Initial problem output outproc = (myid == 0) if (outproc) then - write(6,*) " " - write(6,*) "2D Heat PDE test problem:"; - write(6,'(A,i4)') " nprocs = " , nprocs - write(6,'(A,i4)') " nx = ", nx - write(6,'(A,i4)') " ny = ", ny - write(6,'(A,f5.2)') " kx = ", kx - write(6,'(A,f5.2)') " ky = ", ky - write(6,'(A,es9.2)') " rtol = ", rtol - write(6,'(A,es9.2)') " atol = ", atol - write(6,'(A,i4)') " nxl (proc 0) = ", nxl - write(6,'(A,i4)') " nyl (proc 0) = ", nyl - write(6,*) " " - endif + write (6, *) " " + write (6, *) "2D Heat PDE test problem:"; + write (6, '(A,i4)') " nprocs = ", nprocs + write (6, '(A,i4)') " nx = ", nx + write (6, '(A,i4)') " ny = ", ny + write (6, '(A,f5.2)') " kx = ", kx + write (6, '(A,f5.2)') " ky = ", ky + write (6, '(A,es9.2)') " rtol = ", rtol + write (6, '(A,es9.2)') " atol = ", atol + write (6, '(A,i4)') " nxl (proc 0) = ", nxl + write (6, '(A,i4)') " nyl (proc 0) = ", nyl + write (6, *) " " + end if ! Create solution vector, point at its data, and set initial condition N = nxl*nyl Ntot = nx*ny sunvec_y => FN_VNew_Parallel(comm, N, Ntot, sunctx) - y(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_y) + y(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_y) y = 0.d0 ! Create the ARKStep timestepper module arkode_mem = FARKStepCreate(c_null_funptr, c_funloc(frhs), t0, sunvec_y, sunctx) if (.not. c_associated(arkode_mem)) then - print *, "Error: FARKStepCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKStepCreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Create linear solver sun_LS => FSUNLinSol_PCG(sunvec_y, SUN_PREC_LEFT, int(20, c_int), sunctx) if (.not. associated(sun_LS)) then - print *, "Error: FSUNLinSol_PCG returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNLinSol_PCG returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Attach linear solver sunmat_A => null() retval = FARKodeSetLinearSolver(arkode_mem, sun_LS, sunmat_A) if (retval /= 0) then - print *, "Error: FARKodeSetLinearSolver returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSetLinearSolver returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Attach preconditioner retval = FARKodeSetPreconditioner(arkode_mem, c_funloc(PSetup), & - c_funloc(PSolve)) + c_funloc(PSolve)) if (retval /= 0) then - print *, "Error: FARKodeSetPreconditioner returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSetPreconditioner returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FARKodeSStolerances(arkode_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FARKodeSStolerances returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Specify nonlinear solver convergence coefficient retval = FARKodeSetNonlinConvCoef(arkode_mem, nlscoef) if (retval /= 0) then - print *, "Error: FARKodeSetNonlinConvCoef returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSetNonlinConvCoef returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Specify nonlinear solver predictor method retval = FARKodeSetPredictorMethod(arkode_mem, int(1, c_int)) if (retval /= 0) then - print *, "Error: FARKodeSetNonlinConvCoef returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSetNonlinConvCoef returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Specify that problem is linearly implicit retval = FARKodeSetLinear(arkode_mem, int(0, c_int)) if (retval /= 0) then - print *, "Error: FARKodeSetNonlinConvCoef returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeSetNonlinConvCoef returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! fill in the heat source array - do j=1,nyl - do i=1,nxl - h(i,j) = sin(pi*(is+i-2)*dx) * sin(2.d0*pi*(js+j-2)*dy) - enddo - enddo + do j = 1, nyl + do i = 1, nxl + h(i, j) = sin(pi*(is + i - 2)*dx)*sin(2.d0*pi*(js + j - 2)*dy) + end do + end do ! Each processor outputs subdomain information - write(idstring, "(f4.3)") myid/1000.0 - subdomainname = "heat2d_subdomain" // idstring // ".txt" - open(100, file=subdomainname) - write(100,'(6(i9,1x))') nx, ny, is, ie, js, je - close(100) + write (idstring, "(f4.3)") myid/1000.0 + subdomainname = "heat2d_subdomain"//idstring//".txt" + open (100, file=subdomainname) + write (100, '(6(i9,1x))') nx, ny, is, ie, js, je + close (100) ! Open output streams for results, access data array - outname = "heat2d" // idstring // ".txt" - open(101, file=outname) + outname = "heat2d"//idstring//".txt" + open (101, file=outname) ! Output initial condition to disk - do j=1,nyl - do i=1,nxl - write(101,'(es25.16)',advance='no') y(i,j) - enddo - enddo - write(101,*) " " + do j = 1, nyl + do i = 1, nxl + write (101, '(es25.16)', advance='no') y(i, j) + end do + end do + write (101, *) " " ! create masking vector for computing solution RMS norm sunvec_ones => FN_VNew_Parallel(comm, N, Ntot, sunctx) @@ -841,112 +835,112 @@ program driver ! Main time-stepping loop: calls ARKODE to perform the integration, then ! prints results. Stops when the final time has been reached t(1) = T0 - dTout = (Tf-T0)/Nt - tout = T0+dTout + dTout = (Tf - T0)/Nt + tout = T0 + dTout urms = FN_VWrmsNorm(sunvec_y, sunvec_ones) if (outproc) then - write(6,*) " t ||u||_rms" - write(6,*) " ----------------------" - write(6,'(2(2x,f10.6))') t, urms - endif - do ioutput=1,Nt - - ! Integrate to output time - retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) - if (retval /= 0) then - print *, "Error: FARKodeEvolve returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! print solution stats and update internal time - urms = FN_VWrmsNorm(sunvec_y, sunvec_ones) - if (outproc) write(6,'(2(2x,f10.6))') t, urms - tout = min(tout + dTout, Tf) - - ! output results to disk - do j=1,nyl - do i=1,nxl - write(101,'(es25.16)',advance='no') y(i,j) - enddo - enddo - write(101,*) " " - - enddo + write (6, *) " t ||u||_rms" + write (6, *) " ----------------------" + write (6, '(2(2x,f10.6))') t, urms + end if + do ioutput = 1, Nt + + ! Integrate to output time + retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, t, ARK_NORMAL) + if (retval /= 0) then + print *, "Error: FARKodeEvolve returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! print solution stats and update internal time + urms = FN_VWrmsNorm(sunvec_y, sunvec_ones) + if (outproc) write (6, '(2(2x,f10.6))') t, urms + tout = min(tout + dTout, Tf) + + ! output results to disk + do j = 1, nyl + do i = 1, nxl + write (101, '(es25.16)', advance='no') y(i, j) + end do + end do + write (101, *) " " + + end do if (outproc) then - write(6,*) " ----------------------" - endif - close(101) + write (6, *) " ----------------------" + end if + close (101) ! Get final statistics retval = FARKodeGetNumSteps(arkode_mem, nst) if (retval /= 0) then - print *, "Error: FARKodeGetNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (retval /= 0) then - print *, "Error: FARKodeGetNumStepAttempts returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumStepAttempts returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (retval /= 0) then - print *, "Error: FARKStepGetNumRhsEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKStepGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumErrTestFails(arkode_mem, netf) if (retval /= 0) then - print *, "Error: FARKodeGetNumErrTestFails returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumNonlinSolvIters(arkode_mem, nni) if (retval /= 0) then - print *, "Error: FARKodeGetNumNonlinSolvIters returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumNonlinSolvIters returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumLinConvFails(arkode_mem, ncfn) if (retval /= 0) then - print *, "Error: FARKodeGetNumLinConvFails returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumLinConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumLinIters(arkode_mem, nli) if (retval /= 0) then - print *, "Error: FARKodeGetNumLinIters returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumLinIters returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumPrecEvals(arkode_mem, npre) if (retval /= 0) then - print *, "Error: FARKodeGetNumPrecEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumPrecEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FARKodeGetNumPrecSolves(arkode_mem, npsol) if (retval /= 0) then - print *, "Error: FARKodeGetNumPrecSolves returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FARKodeGetNumPrecSolves returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Print some final statistics if (outproc) then - write(6,*) " " - write(6,*) "Final Solver Statistics:" - write(6,'(2(A,i6),A)') " Internal solver steps = ", nst, & - " (attempted = ", nst_a, ")" - write(6,'(A,i6,A,i6)') " Total RHS evals: Fe = ", nfe, ", Fi = ", nfi - write(6,'(A,i6)') " Total linear iterations = ", nli - write(6,'(A,i6)') " Total number of Preconditioner setups = ", npre - write(6,'(A,i6)') " Total number of Preconditioner solves = ", npsol - write(6,'(A,i6)') " Total number of linear solver convergence failures = ", & - ncfn - write(6,'(A,i6)') " Total number of Newton iterations = ", nni - write(6,'(A,i6)') " Total number of error test failures = ", netf - endif + write (6, *) " " + write (6, *) "Final Solver Statistics:" + write (6, '(2(A,i6),A)') " Internal solver steps = ", nst, & + " (attempted = ", nst_a, ")" + write (6, '(A,i6,A,i6)') " Total RHS evals: Fe = ", nfe, ", Fi = ", nfi + write (6, '(A,i6)') " Total linear iterations = ", nli + write (6, '(A,i6)') " Total number of Preconditioner setups = ", npre + write (6, '(A,i6)') " Total number of Preconditioner solves = ", npsol + write (6, '(A,i6)') " Total number of linear solver convergence failures = ", & + ncfn + write (6, '(A,i6)') " Total number of Newton iterations = ", nni + write (6, '(A,i6)') " Total number of error test failures = ", netf + end if ! Clean up and return with successful completion call FARKodeFree(arkode_mem) ! free integrator memory diff --git a/examples/arkode/F2003_serial/ark_analytic_f2003.f90 b/examples/arkode/F2003_serial/ark_analytic_f2003.f90 index 2df7e977c3..974e0cea02 100644 --- a/examples/arkode/F2003_serial/ark_analytic_f2003.f90 +++ b/examples/arkode/F2003_serial/ark_analytic_f2003.f90 @@ -62,7 +62,7 @@ module analytic_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -74,7 +74,7 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yvec(:) @@ -87,8 +87,7 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec => FN_VGetArrayPointer(sunvec_f) ! fill RHS vector - fvec(1) = lamda*yvec(1) + 1.0/(1.0+tn*tn) - lamda*atan(tn); - + fvec(1) = lamda*yvec(1) + 1.0/(1.0 + tn*tn) - lamda*atan(tn); ! return success ierr = 0 return @@ -99,7 +98,6 @@ end function RhsFn end module analytic_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -131,9 +129,9 @@ program main integer(c_int) :: nout ! number of outputs integer(c_int) :: outstep ! output loop counter - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix - type(SUNLinearSolver), pointer :: sunls ! sundials linear solver + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNLinearSolver), pointer :: sunls ! sundials linear solver type(SUNAdaptController), pointer :: sunCtrl ! time step controller type(c_ptr) :: arkode_mem ! ARKODE memory real(c_double), pointer, dimension(neq) :: yvec(:) ! underlying vector @@ -145,17 +143,17 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 10.0d0 - tcur = tstart - tout = tstart - dtout = 1.0d0 - nout = ceiling(tend/dtout) + tend = 10.0d0 + tcur = tstart + tout = tstart + dtout = 1.0d0 + nout = ceiling(tend/dtout) ! create SUNDIALS N_Vector sunvec_y => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if yvec => FN_VGetArrayPointer(sunvec_y) @@ -164,25 +162,25 @@ program main ! create ARKStep memory arkode_mem = FARKStepCreate(c_null_funptr, c_funloc(RhsFn), tstart, sunvec_y, ctx) - if (.not. c_associated(arkode_mem)) print *,'ERROR: arkode_mem = NULL' + if (.not. c_associated(arkode_mem)) print *, 'ERROR: arkode_mem = NULL' ! Tell ARKODE to use a dense linear solver. sunmat_A => FSUNDenseMatrix(neq, neq, ctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if sunls => FSUNLinSol_Dense(sunvec_y, sunmat_A, ctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - stop 1 + print *, 'ERROR: sunls = NULL' + stop 1 end if ierr = FARKodeSetLinearSolver(arkode_mem, sunls, sunmat_A) if (ierr /= 0) then - write(*,*) 'Error in FARKodeSetLinearSolver' - stop 1 + write (*, *) 'Error in FARKodeSetLinearSolver' + stop 1 end if ! set relative and absolute tolerances @@ -191,25 +189,25 @@ program main ierr = FARKodeSStolerances(arkode_mem, rtol, atol) if (ierr /= 0) then - write(*,*) 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + write (*, *) 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if sunCtrl => FSUNAdaptController_ImpGus(ctx) if (.not. associated(sunCtrl)) then - print *, 'ERROR: sunCtrl = NULL' - stop 1 + print *, 'ERROR: sunCtrl = NULL' + stop 1 end if ierr = FARKodeSetAdaptController(arkode_mem, sunCtrl) if (ierr /= 0) then - write(*,*) 'Error in FARKodeSetAdaptController, ierr = ', ierr, '; halting' - stop 1 + write (*, *) 'Error in FARKodeSetAdaptController, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeSetNonlinConvCoef(arkode_mem, 0.01d0) if (ierr /= 0) then - write(*,*) 'Error in FARKodeSetNonlinConvCoef, ierr = ', ierr, '; halting' - stop 1 + write (*, *) 'Error in FARKodeSetNonlinConvCoef, ierr = ', ierr, '; halting' + stop 1 end if ! Start time stepping @@ -219,20 +217,20 @@ program main print *, ' t y ' print *, '----------------------------' print '(2x,2(es12.5,1x))', tcur, yvec(1) - do outstep = 1,nout + do outstep = 1, nout - ! call ARKodeEvolve - tout = min(tout + dtout, tend) - ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) - if (ierr /= 0) then - write(*,*) 'Error in FARKODE, ierr = ', ierr, '; halting' - stop 1 - endif + ! call ARKodeEvolve + tout = min(tout + dtout, tend) + ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) + if (ierr /= 0) then + write (*, *) 'Error in FARKODE, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(2x,2(es12.5,1x))', tcur, yvec(1) + ! output current solution + print '(2x,2(es12.5,1x))', tcur, yvec(1) - enddo + end do ! diagnostics output call ARKStepStats(arkode_mem) @@ -248,7 +246,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! ARKStepStats ! @@ -289,90 +286,90 @@ subroutine ARKStepStats(arkode_mem) ierr = FARKodeGetNumSteps(arkode_mem, nsteps) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumSteps, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumStepAttempts, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumStepAttempts, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (ierr /= 0) then - print *, 'Error in FARKStepGetNumRhsEvals, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKStepGetNumRhsEvals, retval = ', ierr, '; halting' + stop 1 end if - nfevals=nfe+nfi + nfevals = nfe + nfi ierr = FARKodeGetActualInitStep(arkode_mem, hinused) if (ierr /= 0) then - print *, 'Error in FARKodeGetActualInitStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetActualInitStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetLastStep(arkode_mem, hlast) if (ierr /= 0) then - print *, 'Error in FARKodeGetLastStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetLastStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetCurrentStep(arkode_mem, hcur) if (ierr /= 0) then - print *, 'Error in FARKodeGetCurrentStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetCurrentTime(arkode_mem, tcur) if (ierr /= 0) then - print *, 'Error in FARKodeGetCurrentTime, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentTime, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumLinSolvSetups(arkode_mem, nlinsetups) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumErrTestFails(arkode_mem, netfails) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumErrTestFails, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumErrTestFails, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvIters(arkode_mem, nniters) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvConvFails(arkode_mem, nncfails) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumJacEvals(arkode_mem, njacevals) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumJacEvals, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumJacEvals, retval = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total internal steps attempts =',nst_a - print '(4x,A,i9)' ,'Total rhs function calls =',nfevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total internal steps attempts =', nst_a + print '(4x,A,i9)', 'Total rhs function calls =', nfevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/arkode/F2003_serial/ark_bruss1D_FEM_klu_f2003.f90 b/examples/arkode/F2003_serial/ark_bruss1D_FEM_klu_f2003.f90 index 80908e0127..0d63e260cf 100644 --- a/examples/arkode/F2003_serial/ark_bruss1D_FEM_klu_f2003.f90 +++ b/examples/arkode/F2003_serial/ark_bruss1D_FEM_klu_f2003.f90 @@ -105,36 +105,36 @@ module FEMBasis contains ! left/right basis functions - real(c_double) function ChiL(xl,xr,x) + real(c_double) function ChiL(xl, xr, x) real(c_double) :: xl, xr, x - ChiL = (xr-x)/(xr-xl) + ChiL = (xr - x)/(xr - xl) end function ChiL - real(c_double) function ChiR(xl,xr,x) + real(c_double) function ChiR(xl, xr, x) real(c_double) :: xl, xr, x - ChiR = (x-xl)/(xr-xl) + ChiR = (x - xl)/(xr - xl) end function ChiR ! derivatives of left/right basis functions - real(c_double) function ChiL_x(xl,xr) + real(c_double) function ChiL_x(xl, xr) real(c_double) :: xl, xr - ChiL_x = 1.d0/(xl-xr) + ChiL_x = 1.d0/(xl - xr) end function ChiL_X - real(c_double) function ChiR_x(xl,xr) + real(c_double) function ChiR_x(xl, xr) real(c_double) :: xl, xr - ChiR_x = 1.d0/(xr-xl) + ChiR_x = 1.d0/(xr - xl) end function ChiR_x ! FEM output evaluation routines: value and derivative - real(c_double) function Eval(ul,ur,xl,xr,x) + real(c_double) function Eval(ul, ur, xl, xr, x) real(c_double) :: ul, ur, xl, xr, x - Eval = ul*ChiL(xl,xr,x) + ur*ChiR(xl,xr,x) + Eval = ul*ChiL(xl, xr, x) + ur*ChiR(xl, xr, x) end function Eval - real(c_double) function Eval_x(ul,ur,xl,xr) + real(c_double) function Eval_x(ul, ur, xl, xr) real(c_double) :: ul, ur, xl, xr - Eval_x = ul*ChiL_x(xl,xr) + ur*ChiR_x(xl,xr) + Eval_x = ul*ChiL_x(xl, xr) + ur*ChiR_x(xl, xr) end function Eval_x end module FEMBasis @@ -147,28 +147,28 @@ module Quadrature contains ! nodes - real(c_double) function X1(xl,xr) + real(c_double) function X1(xl, xr) real(c_double) :: xl, xr - X1 = 0.5d0*(xl+xr) - 0.5d0*(xr-xl)*0.774596669241483377035853079956d0 + X1 = 0.5d0*(xl + xr) - 0.5d0*(xr - xl)*0.774596669241483377035853079956d0 end function X1 - real(c_double) function X2(xl,xr) + real(c_double) function X2(xl, xr) real(c_double) :: xl, xr - X2 = 0.5d0*(xl+xr) + X2 = 0.5d0*(xl + xr) end function X2 - real(c_double) function X3(xl,xr) + real(c_double) function X3(xl, xr) real(c_double) :: xl, xr - X3 = 0.5d0*(xl+xr) + 0.5d0*(xr-xl)*0.774596669241483377035853079956d0 + X3 = 0.5d0*(xl + xr) + 0.5d0*(xr - xl)*0.774596669241483377035853079956d0 end function X3 ! quadrature - real(c_double) function Quad(f1,f2,f3,xl,xr) + real(c_double) function Quad(f1, f2, f3, xl, xr) real(c_double) :: f1, f2, f3, xl, xr - real(c_double), parameter :: wt1=0.55555555555555555555555555555556d0 - real(c_double), parameter :: wt2=0.88888888888888888888888888888889d0 - real(c_double), parameter :: wt3=0.55555555555555555555555555555556d0 - Quad = 0.5d0*(xr-xl)*(wt1*f1 + wt2*f2 + wt3*f3) + real(c_double), parameter :: wt1 = 0.55555555555555555555555555555556d0 + real(c_double), parameter :: wt2 = 0.88888888888888888888888888888889d0 + real(c_double), parameter :: wt3 = 0.55555555555555555555555555555556d0 + Quad = 0.5d0*(xr - xl)*(wt1*f1 + wt2*f2 + wt3*f3) end function Quad end module Quadrature @@ -195,7 +195,7 @@ module bruss1D_ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use FEMBasis @@ -208,7 +208,7 @@ integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! Local data integer(c_int64_t) :: ix @@ -216,8 +216,8 @@ integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double) :: ul, ur, vl, vr, wl, wr, xl, xr, u, v, w, f1, f2, f3 ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(neqreal, N) :: yvec(:,:) - real(c_double), pointer, dimension(neqreal, N) :: fvec(:,:) + real(c_double), pointer, dimension(neqreal, N) :: yvec(:, :) + real(c_double), pointer, dimension(neqreal, N) :: fvec(:, :) !======= Internals ============ @@ -229,149 +229,149 @@ integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec = 0.d0 ! iterate over intervals, filling in rhs function - do ix=1,N-1 - - ! set booleans to determine whether equations exist on the left/right */ - left = .true. - right = .true. - if (ix==1) left = .false. - if (ix==(N-1)) right = .false. - - ! set nodal value shortcuts (interval index aligns with left node) - ul = yvec(1,ix) - vl = yvec(2,ix) - wl = yvec(3,ix) - ur = yvec(1,ix+1) - vr = yvec(2,ix+1) - wr = yvec(3,ix+1) - - ! set mesh shortcuts - xl = x(ix) - xr = x(ix+1) - - ! left test function - if (left) then - - ! u -- reaction - u = Eval(ul, ur, xl, xr, X1(xl,xr)) - v = Eval(vl, vr, xl, xr, X1(xl,xr)) - w = Eval(wl, wr, xl, xr, X1(xl,xr)) - f1 = (a - (w+1.d0)*u + v*u*u) * ChiL(xl,xr,X1(xl,xr)) - u = Eval(ul, ur, xl, xr, X2(xl,xr)) - v = Eval(vl, vr, xl, xr, X2(xl,xr)) - w = Eval(wl, wr, xl, xr, X2(xl,xr)) - f2 = (a - (w+1.d0)*u + v*u*u) * ChiL(xl,xr,X2(xl,xr)) - u = Eval(ul, ur, xl, xr, X3(xl,xr)) - v = Eval(vl, vr, xl, xr, X3(xl,xr)) - w = Eval(wl, wr, xl, xr, X3(xl,xr)) - f3 = (a - (w+1.d0)*u + v*u*u) * ChiL(xl,xr,X3(xl,xr)) - fvec(1,ix) = fvec(1,ix) + Quad(f1,f2,f3,xl,xr) - - ! u -- diffusion - f1 = -du * Eval_x(ul,ur,xl,xr) * ChiL_x(xl,xr) - fvec(1,ix) = fvec(1,ix) + Quad(f1,f1,f1,xl,xr) - - ! v -- reaction - u = Eval(ul, ur, xl, xr, X1(xl,xr)) - v = Eval(vl, vr, xl, xr, X1(xl,xr)) - w = Eval(wl, wr, xl, xr, X1(xl,xr)) - f1 = (w*u - v*u*u) * ChiL(xl,xr,X1(xl,xr)) - u = Eval(ul, ur, xl, xr, X2(xl,xr)) - v = Eval(vl, vr, xl, xr, X2(xl,xr)) - w = Eval(wl, wr, xl, xr, X2(xl,xr)) - f2 = (w*u - v*u*u) * ChiL(xl,xr,X2(xl,xr)) - u = Eval(ul, ur, xl, xr, X3(xl,xr)) - v = Eval(vl, vr, xl, xr, X3(xl,xr)) - w = Eval(wl, wr, xl, xr, X3(xl,xr)) - f3 = (w*u - v*u*u) * ChiL(xl,xr,X3(xl,xr)) - fvec(2,ix) = fvec(2,ix) + Quad(f1,f2,f3,xl,xr) - - ! v -- diffusion - f1 = -dv * Eval_x(vl,vr,xl,xr) * ChiL_x(xl,xr) - fvec(2,ix) = fvec(2,ix) + Quad(f1,f1,f1,xl,xr) - - ! w -- reaction - u = Eval(ul, ur, xl, xr, X1(xl,xr)) - v = Eval(vl, vr, xl, xr, X1(xl,xr)) - w = Eval(wl, wr, xl, xr, X1(xl,xr)) - f1 = ((b-w)/ep - w*u) * ChiL(xl,xr,X1(xl,xr)) - u = Eval(ul, ur, xl, xr, X2(xl,xr)) - v = Eval(vl, vr, xl, xr, X2(xl,xr)) - w = Eval(wl, wr, xl, xr, X2(xl,xr)) - f2 = ((b-w)/ep - w*u) * ChiL(xl,xr,X2(xl,xr)) - u = Eval(ul, ur, xl, xr, X3(xl,xr)) - v = Eval(vl, vr, xl, xr, X3(xl,xr)) - w = Eval(wl, wr, xl, xr, X3(xl,xr)) - f3 = ((b-w)/ep - w*u) * ChiL(xl,xr,X3(xl,xr)) - fvec(3,ix) = fvec(3,ix) + Quad(f1,f2,f3,xl,xr) - - ! w -- diffusion - f1 = -dw * Eval_x(wl,wr,xl,xr) * ChiL_x(xl,xr) - fvec(3,ix) = fvec(3,ix) + Quad(f1,f1,f1,xl,xr) - - end if - - ! right test function - if (right) then - - ! u -- reaction - u = Eval(ul, ur, xl, xr, X1(xl,xr)) - v = Eval(vl, vr, xl, xr, X1(xl,xr)) - w = Eval(wl, wr, xl, xr, X1(xl,xr)) - f1 = (a - (w+1.d0)*u + v*u*u) * ChiR(xl,xr,X1(xl,xr)) - u = Eval(ul, ur, xl, xr, X2(xl,xr)) - v = Eval(vl, vr, xl, xr, X2(xl,xr)) - w = Eval(wl, wr, xl, xr, X2(xl,xr)) - f2 = (a - (w+1.d0)*u + v*u*u) * ChiR(xl,xr,X2(xl,xr)) - u = Eval(ul, ur, xl, xr, X3(xl,xr)) - v = Eval(vl, vr, xl, xr, X3(xl,xr)) - w = Eval(wl, wr, xl, xr, X3(xl,xr)) - f3 = (a - (w+1.d0)*u + v*u*u) * ChiR(xl,xr,X3(xl,xr)) - fvec(1,ix+1) = fvec(1,ix+1) + Quad(f1,f2,f3,xl,xr) - - ! u -- diffusion - f1 = -du * Eval_x(ul,ur,xl,xr) * ChiR_x(xl,xr) - fvec(1,ix+1) = fvec(1,ix+1) + Quad(f1,f1,f1,xl,xr) - - ! v -- reaction - u = Eval(ul, ur, xl, xr, X1(xl,xr)) - v = Eval(vl, vr, xl, xr, X1(xl,xr)) - w = Eval(wl, wr, xl, xr, X1(xl,xr)) - f1 = (w*u - v*u*u) * ChiR(xl,xr,X1(xl,xr)) - u = Eval(ul, ur, xl, xr, X2(xl,xr)) - v = Eval(vl, vr, xl, xr, X2(xl,xr)) - w = Eval(wl, wr, xl, xr, X2(xl,xr)) - f2 = (w*u - v*u*u) * ChiR(xl,xr,X2(xl,xr)) - u = Eval(ul, ur, xl, xr, X3(xl,xr)) - v = Eval(vl, vr, xl, xr, X3(xl,xr)) - w = Eval(wl, wr, xl, xr, X3(xl,xr)) - f3 = (w*u - v*u*u) * ChiR(xl,xr,X3(xl,xr)) - fvec(2,ix+1) = fvec(2,ix+1) + Quad(f1,f2,f3,xl,xr) - - ! v -- diffusion - f1 = -dv * Eval_x(vl,vr,xl,xr) * ChiR_x(xl,xr) - fvec(2,ix+1) = fvec(2,ix+1) + Quad(f1,f1,f1,xl,xr) - - ! w -- reaction - u = Eval(ul, ur, xl, xr, X1(xl,xr)) - v = Eval(vl, vr, xl, xr, X1(xl,xr)) - w = Eval(wl, wr, xl, xr, X1(xl,xr)) - f1 = ((b-w)/ep - w*u) * ChiR(xl,xr,X1(xl,xr)) - u = Eval(ul, ur, xl, xr, X2(xl,xr)) - v = Eval(vl, vr, xl, xr, X2(xl,xr)) - w = Eval(wl, wr, xl, xr, X2(xl,xr)) - f2 = ((b-w)/ep - w*u) * ChiR(xl,xr,X2(xl,xr)) - u = Eval(ul, ur, xl, xr, X3(xl,xr)) - v = Eval(vl, vr, xl, xr, X3(xl,xr)) - w = Eval(wl, wr, xl, xr, X3(xl,xr)) - f3 = ((b-w)/ep - w*u) * ChiR(xl,xr,X3(xl,xr)) - fvec(3,ix+1) = fvec(3,ix+1) + Quad(f1,f2,f3,xl,xr) - - ! w -- diffusion - f1 = -dw * Eval_x(wl,wr,xl,xr) * ChiR_x(xl,xr) - fvec(3,ix+1) = fvec(3,ix+1) + Quad(f1,f1,f1,xl,xr) - - end if + do ix = 1, N - 1 + + ! set booleans to determine whether equations exist on the left/right */ + left = .true. + right = .true. + if (ix == 1) left = .false. + if (ix == (N - 1)) right = .false. + + ! set nodal value shortcuts (interval index aligns with left node) + ul = yvec(1, ix) + vl = yvec(2, ix) + wl = yvec(3, ix) + ur = yvec(1, ix + 1) + vr = yvec(2, ix + 1) + wr = yvec(3, ix + 1) + + ! set mesh shortcuts + xl = x(ix) + xr = x(ix + 1) + + ! left test function + if (left) then + + ! u -- reaction + u = Eval(ul, ur, xl, xr, X1(xl, xr)) + v = Eval(vl, vr, xl, xr, X1(xl, xr)) + w = Eval(wl, wr, xl, xr, X1(xl, xr)) + f1 = (a - (w + 1.d0)*u + v*u*u)*ChiL(xl, xr, X1(xl, xr)) + u = Eval(ul, ur, xl, xr, X2(xl, xr)) + v = Eval(vl, vr, xl, xr, X2(xl, xr)) + w = Eval(wl, wr, xl, xr, X2(xl, xr)) + f2 = (a - (w + 1.d0)*u + v*u*u)*ChiL(xl, xr, X2(xl, xr)) + u = Eval(ul, ur, xl, xr, X3(xl, xr)) + v = Eval(vl, vr, xl, xr, X3(xl, xr)) + w = Eval(wl, wr, xl, xr, X3(xl, xr)) + f3 = (a - (w + 1.d0)*u + v*u*u)*ChiL(xl, xr, X3(xl, xr)) + fvec(1, ix) = fvec(1, ix) + Quad(f1, f2, f3, xl, xr) + + ! u -- diffusion + f1 = -du*Eval_x(ul, ur, xl, xr)*ChiL_x(xl, xr) + fvec(1, ix) = fvec(1, ix) + Quad(f1, f1, f1, xl, xr) + + ! v -- reaction + u = Eval(ul, ur, xl, xr, X1(xl, xr)) + v = Eval(vl, vr, xl, xr, X1(xl, xr)) + w = Eval(wl, wr, xl, xr, X1(xl, xr)) + f1 = (w*u - v*u*u)*ChiL(xl, xr, X1(xl, xr)) + u = Eval(ul, ur, xl, xr, X2(xl, xr)) + v = Eval(vl, vr, xl, xr, X2(xl, xr)) + w = Eval(wl, wr, xl, xr, X2(xl, xr)) + f2 = (w*u - v*u*u)*ChiL(xl, xr, X2(xl, xr)) + u = Eval(ul, ur, xl, xr, X3(xl, xr)) + v = Eval(vl, vr, xl, xr, X3(xl, xr)) + w = Eval(wl, wr, xl, xr, X3(xl, xr)) + f3 = (w*u - v*u*u)*ChiL(xl, xr, X3(xl, xr)) + fvec(2, ix) = fvec(2, ix) + Quad(f1, f2, f3, xl, xr) + + ! v -- diffusion + f1 = -dv*Eval_x(vl, vr, xl, xr)*ChiL_x(xl, xr) + fvec(2, ix) = fvec(2, ix) + Quad(f1, f1, f1, xl, xr) + + ! w -- reaction + u = Eval(ul, ur, xl, xr, X1(xl, xr)) + v = Eval(vl, vr, xl, xr, X1(xl, xr)) + w = Eval(wl, wr, xl, xr, X1(xl, xr)) + f1 = ((b - w)/ep - w*u)*ChiL(xl, xr, X1(xl, xr)) + u = Eval(ul, ur, xl, xr, X2(xl, xr)) + v = Eval(vl, vr, xl, xr, X2(xl, xr)) + w = Eval(wl, wr, xl, xr, X2(xl, xr)) + f2 = ((b - w)/ep - w*u)*ChiL(xl, xr, X2(xl, xr)) + u = Eval(ul, ur, xl, xr, X3(xl, xr)) + v = Eval(vl, vr, xl, xr, X3(xl, xr)) + w = Eval(wl, wr, xl, xr, X3(xl, xr)) + f3 = ((b - w)/ep - w*u)*ChiL(xl, xr, X3(xl, xr)) + fvec(3, ix) = fvec(3, ix) + Quad(f1, f2, f3, xl, xr) + + ! w -- diffusion + f1 = -dw*Eval_x(wl, wr, xl, xr)*ChiL_x(xl, xr) + fvec(3, ix) = fvec(3, ix) + Quad(f1, f1, f1, xl, xr) + + end if + + ! right test function + if (right) then + + ! u -- reaction + u = Eval(ul, ur, xl, xr, X1(xl, xr)) + v = Eval(vl, vr, xl, xr, X1(xl, xr)) + w = Eval(wl, wr, xl, xr, X1(xl, xr)) + f1 = (a - (w + 1.d0)*u + v*u*u)*ChiR(xl, xr, X1(xl, xr)) + u = Eval(ul, ur, xl, xr, X2(xl, xr)) + v = Eval(vl, vr, xl, xr, X2(xl, xr)) + w = Eval(wl, wr, xl, xr, X2(xl, xr)) + f2 = (a - (w + 1.d0)*u + v*u*u)*ChiR(xl, xr, X2(xl, xr)) + u = Eval(ul, ur, xl, xr, X3(xl, xr)) + v = Eval(vl, vr, xl, xr, X3(xl, xr)) + w = Eval(wl, wr, xl, xr, X3(xl, xr)) + f3 = (a - (w + 1.d0)*u + v*u*u)*ChiR(xl, xr, X3(xl, xr)) + fvec(1, ix + 1) = fvec(1, ix + 1) + Quad(f1, f2, f3, xl, xr) + + ! u -- diffusion + f1 = -du*Eval_x(ul, ur, xl, xr)*ChiR_x(xl, xr) + fvec(1, ix + 1) = fvec(1, ix + 1) + Quad(f1, f1, f1, xl, xr) + + ! v -- reaction + u = Eval(ul, ur, xl, xr, X1(xl, xr)) + v = Eval(vl, vr, xl, xr, X1(xl, xr)) + w = Eval(wl, wr, xl, xr, X1(xl, xr)) + f1 = (w*u - v*u*u)*ChiR(xl, xr, X1(xl, xr)) + u = Eval(ul, ur, xl, xr, X2(xl, xr)) + v = Eval(vl, vr, xl, xr, X2(xl, xr)) + w = Eval(wl, wr, xl, xr, X2(xl, xr)) + f2 = (w*u - v*u*u)*ChiR(xl, xr, X2(xl, xr)) + u = Eval(ul, ur, xl, xr, X3(xl, xr)) + v = Eval(vl, vr, xl, xr, X3(xl, xr)) + w = Eval(wl, wr, xl, xr, X3(xl, xr)) + f3 = (w*u - v*u*u)*ChiR(xl, xr, X3(xl, xr)) + fvec(2, ix + 1) = fvec(2, ix + 1) + Quad(f1, f2, f3, xl, xr) + + ! v -- diffusion + f1 = -dv*Eval_x(vl, vr, xl, xr)*ChiR_x(xl, xr) + fvec(2, ix + 1) = fvec(2, ix + 1) + Quad(f1, f1, f1, xl, xr) + + ! w -- reaction + u = Eval(ul, ur, xl, xr, X1(xl, xr)) + v = Eval(vl, vr, xl, xr, X1(xl, xr)) + w = Eval(wl, wr, xl, xr, X1(xl, xr)) + f1 = ((b - w)/ep - w*u)*ChiR(xl, xr, X1(xl, xr)) + u = Eval(ul, ur, xl, xr, X2(xl, xr)) + v = Eval(vl, vr, xl, xr, X2(xl, xr)) + w = Eval(wl, wr, xl, xr, X2(xl, xr)) + f2 = ((b - w)/ep - w*u)*ChiR(xl, xr, X2(xl, xr)) + u = Eval(ul, ur, xl, xr, X3(xl, xr)) + v = Eval(vl, vr, xl, xr, X3(xl, xr)) + w = Eval(wl, wr, xl, xr, X3(xl, xr)) + f3 = ((b - w)/ep - w*u)*ChiR(xl, xr, X3(xl, xr)) + fvec(3, ix + 1) = fvec(3, ix + 1) + Quad(f1, f2, f3, xl, xr) + + ! w -- diffusion + f1 = -dw*Eval_x(wl, wr, xl, xr)*ChiR_x(xl, xr) + fvec(3, ix + 1) = fvec(3, ix + 1) + Quad(f1, f1, f1, xl, xr) + + end if end do @@ -382,7 +382,6 @@ integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & end function ImpRhsFn ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Jac: The Jacobian function ! @@ -392,7 +391,7 @@ end function ImpRhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & - sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) bind(C,name='Jac') + sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) bind(C, name='Jac') !======= Inclusions =========== use FEMBasis @@ -408,7 +407,7 @@ integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 @@ -419,29 +418,28 @@ integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & real(c_double) :: u1, u2, u3, v1, v2, v3, w1, w2, w3 real(c_double) :: df1, df2, df3, dQdf1, dQdf2, dQdf3 real(c_double) :: ChiL1, ChiL2, ChiL3, ChiR1, ChiR2, ChiR3 - real(c_double), dimension(3,-1:1) :: Ju, Jv, Jw + real(c_double), dimension(3, -1:1) :: Ju, Jv, Jw ! pointers to data in SUNDIALS vectors integer(c_int64_t), pointer, dimension(nnz) :: Jcolvals(:) - integer(c_int64_t), pointer, dimension(neq+1) :: Jrowptrs(:) - real(c_double), pointer, dimension(nnz) :: Jdata(:) - real(c_double), pointer, dimension(neqreal,N) :: yvec(:,:) - real(c_double), pointer, dimension(neqreal,N) :: fvec(:,:) - + integer(c_int64_t), pointer, dimension(neq + 1) :: Jrowptrs(:) + real(c_double), pointer, dimension(nnz) :: Jdata(:) + real(c_double), pointer, dimension(neqreal, N) :: yvec(:, :) + real(c_double), pointer, dimension(neqreal, N) :: fvec(:, :) !======= Internals ============ ! get data arrays from SUNDIALS vectors yvec(1:neqreal, 1:N) => FN_VGetArrayPointer(sunvec_y) fvec(1:neqreal, 1:N) => FN_VGetArrayPointer(sunvec_f) - Jdata(1:nnz) => FSUNSparseMatrix_Data(sunmat_J) - Jcolvals(1:nnz) => FSUNSparseMatrix_IndexValues(sunmat_J) - Jrowptrs(1:neq+1) => FSUNSparseMatrix_IndexPointers(sunmat_J) + Jdata(1:nnz) => FSUNSparseMatrix_Data(sunmat_J) + Jcolvals(1:nnz) => FSUNSparseMatrix_IndexValues(sunmat_J) + Jrowptrs(1:neq + 1) => FSUNSparseMatrix_IndexPointers(sunmat_J) ! check that vector/matrix dimensions match up - if ((3*N /= neq) .or. (nnz < 27*(N-2))) then - ierr = 1 - return + if ((3*N /= neq) .or. (nnz < 27*(N - 2))) then + ierr = 1 + return end if ! set integer*4 version of N for call to idx() @@ -452,390 +450,381 @@ integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & nz = 0 ! Dirichlet boundary at left - Jrowptrs(idx(1_c_int64_t,1)+1) = nz - Jrowptrs(idx(1_c_int64_t,2)+1) = nz - Jrowptrs(idx(1_c_int64_t,3)+1) = nz + Jrowptrs(idx(1_c_int64_t, 1) + 1) = nz + Jrowptrs(idx(1_c_int64_t, 2) + 1) = nz + Jrowptrs(idx(1_c_int64_t, 3) + 1) = nz ! iterate through nodes, filling in matrix by rows - do ix=2,N-1 - - ! set nodal value shortcuts (interval index aligns with left node) - xl = x(ix-1) - ul = yvec(1,ix-1) - vl = yvec(2,ix-1) - wl = yvec(3,ix-1) - xc = x(ix) - uc = yvec(1,ix) - vc = yvec(2,ix) - wc = yvec(3,ix) - xr = x(ix+1) - ur = yvec(1,ix+1) - vr = yvec(2,ix+1) - wr = yvec(3,ix+1) - - ! compute entries of all Jacobian rows at node ix - Ju = 0.d0 - Jv = 0.d0 - Jw = 0.d0 - - ! first compute dependence on values to left and center - - ! evaluate relevant variables in left subinterval - u1 = Eval(ul, uc, xl, xc, X1(xl,xc)) - v1 = Eval(vl, vc, xl, xc, X1(xl,xc)) - w1 = Eval(wl, wc, xl, xc, X1(xl,xc)) - u2 = Eval(ul, uc, xl, xc, X2(xl,xc)) - v2 = Eval(vl, vc, xl, xc, X2(xl,xc)) - w2 = Eval(wl, wc, xl, xc, X2(xl,xc)) - u3 = Eval(ul, uc, xl, xc, X3(xl,xc)) - v3 = Eval(vl, vc, xl, xc, X3(xl,xc)) - w3 = Eval(wl, wc, xl, xc, X3(xl,xc)) - - dQdf1 = Quad(1.d0, 0.d0, 0.d0, xl, xc) - dQdf2 = Quad(0.d0, 1.d0, 0.d0, xl, xc) - dQdf3 = Quad(0.d0, 0.d0, 1.d0, xl, xc) - - ChiL1 = ChiL(xl, xc, X1(xl,xc)) - ChiL2 = ChiL(xl, xc, X2(xl,xc)) - ChiL3 = ChiL(xl, xc, X3(xl,xc)) - ChiR1 = ChiR(xl, xc, X1(xl,xc)) - ChiR2 = ChiR(xl, xc, X2(xl,xc)) - ChiR3 = ChiR(xl, xc, X3(xl,xc)) - - ! compute diffusion Jacobian components - - ! L_u = -du * u_x * ChiR_x - ! dL_u/dul - Ju(1,-1) = (-du) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiL_x(xl,xc) * ChiR_x(xl,xc) - ! dL_u/duc - Ju(1,0) = (-du) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiR_x(xl,xc) * ChiR_x(xl,xc) - - ! L_v = -dv * v_x * ChiR_x - ! dL_v/dvl - Jv(2,-1) = (-dv) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiL_x(xl,xc) * ChiR_x(xl,xc) - ! dL_v/dvc - Jv(2,0) = (-dv) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiR_x(xl,xc) * ChiR_x(xl,xc) - - ! L_w = -dw * w_x * ChiR_x - ! dL_w/dwl - Jw(3,-1) = (-dw) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiL_x(xl,xc) * ChiR_x(xl,xc) - ! dL_w/dwc - Jw(3,0) = (-dw) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiR_x(xl,xc) * ChiR_x(xl,xc) - - - ! compute reaction Jacobian components - - ! R_u = (a - (w+1.d0)*u + v*u*u) - ! dR_u/dul - df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiL1 * ChiR1 - df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiL2 * ChiR2 - df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiL3 * ChiR3 - Ju(1,-1) = Ju(1,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/duc - df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiR1 * ChiR1 - df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiR2 * ChiR2 - df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiR3 * ChiR3 - Ju(1,0) = Ju(1,0)+ dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dvl - df1 = (u1*u1) * ChiL1 * ChiR1 - df2 = (u2*u2) * ChiL2 * ChiR2 - df3 = (u3*u3) * ChiL3 * ChiR3 - Ju(2,-1) = Ju(2,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dvc - df1 = (u1*u1) * ChiR1 * ChiR1 - df2 = (u2*u2) * ChiR2 * ChiR2 - df3 = (u3*u3) * ChiR3 * ChiR3 - Ju(2,0) = Ju(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dwl - df1 = (-u1) * ChiL1 * ChiR1 - df2 = (-u2) * ChiL2 * ChiR2 - df3 = (-u3) * ChiL3 * ChiR3 - Ju(3,-1) = Ju(3,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dwc - df1 = (-u1) * ChiR1 * ChiR1 - df2 = (-u2) * ChiR2 * ChiR2 - df3 = (-u3) * ChiR3 * ChiR3 - Ju(3,0) = Ju(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - - ! R_v = (w*u - v*u*u) - ! dR_v/dul - df1 = (w1 - 2.d0*v1*u1) * ChiL1 * ChiR1 - df2 = (w2 - 2.d0*v2*u2) * ChiL2 * ChiR2 - df3 = (w3 - 2.d0*v3*u3) * ChiL3 * ChiR3 - Jv(1,-1) = Jv(1,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/duc - df1 = (w1 - 2.d0*v1*u1) * ChiR1 * ChiR1 - df2 = (w2 - 2.d0*v2*u2) * ChiR2 * ChiR2 - df3 = (w3 - 2.d0*v3*u3) * ChiR3 * ChiR3 - Jv(1,0) = Jv(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dvl - df1 = (-u1*u1) * ChiL1 * ChiR1 - df2 = (-u2*u2) * ChiL2 * ChiR2 - df3 = (-u3*u3) * ChiL3 * ChiR3 - Jv(2,-1) = Jv(2,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dvc - df1 = (-u1*u1) * ChiR1 * ChiR1 - df2 = (-u2*u2) * ChiR2 * ChiR2 - df3 = (-u3*u3) * ChiR3 * ChiR3 - Jv(2,0) = Jv(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dwl - df1 = (u1) * ChiL1 * ChiR1 - df2 = (u2) * ChiL2 * ChiR2 - df3 = (u3) * ChiL3 * ChiR3 - Jv(3,-1) = Jv(3,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dwc - df1 = (u1) * ChiR1 * ChiR1 - df2 = (u2) * ChiR2 * ChiR2 - df3 = (u3) * ChiR3 * ChiR3 - Jv(3,0) = Jv(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - - ! R_w = ((b-w)/ep - w*u) - ! dR_w/dul - df1 = (-w1) * ChiL1 * ChiR1 - df2 = (-w2) * ChiL2 * ChiR2 - df3 = (-w3) * ChiL3 * ChiR3 - Jw(1,-1) = Jw(1,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_w/duc - df1 = (-w1) * ChiR1 * ChiR1 - df2 = (-w2) * ChiR2 * ChiR2 - df3 = (-w3) * ChiR3 * ChiR3 - Jw(1,0) = Jw(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_w/dwl - df1 = (-1.d0/ep - u1) * ChiL1 * ChiR1 - df2 = (-1.d0/ep - u2) * ChiL2 * ChiR2 - df3 = (-1.d0/ep - u3) * ChiL3 * ChiR3 - Jw(3,-1) = Jw(3,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_w/dwc - df1 = (-1.d0/ep - u1) * ChiR1 * ChiR1 - df2 = (-1.d0/ep - u2) * ChiR2 * ChiR2 - df3 = (-1.d0/ep - u3) * ChiR3 * ChiR3 - Jw(3,0) = Jw(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - - ! second compute dependence on values to center and right - - ! evaluate relevant variables in right subinterval - u1 = Eval(uc, ur, xc, xr, X1(xc,xr)) - v1 = Eval(vc, vr, xc, xr, X1(xc,xr)) - w1 = Eval(wc, wr, xc, xr, X1(xc,xr)) - u2 = Eval(uc, ur, xc, xr, X2(xc,xr)) - v2 = Eval(vc, vr, xc, xr, X2(xc,xr)) - w2 = Eval(wc, wr, xc, xr, X2(xc,xr)) - u3 = Eval(uc, ur, xc, xr, X3(xc,xr)) - v3 = Eval(vc, vr, xc, xr, X3(xc,xr)) - w3 = Eval(wc, wr, xc, xr, X3(xc,xr)) - - dQdf1 = Quad(1.d0, 0.d0, 0.d0, xc, xr) - dQdf2 = Quad(0.d0, 1.d0, 0.d0, xc, xr) - dQdf3 = Quad(0.d0, 0.d0, 1.d0, xc, xr) - - ChiL1 = ChiL(xc, xr, X1(xc,xr)) - ChiL2 = ChiL(xc, xr, X2(xc,xr)) - ChiL3 = ChiL(xc, xr, X3(xc,xr)) - ChiR1 = ChiR(xc, xr, X1(xc,xr)) - ChiR2 = ChiR(xc, xr, X2(xc,xr)) - ChiR3 = ChiR(xc, xr, X3(xc,xr)) - - - ! compute diffusion Jacobian components - - ! L_u = -du * u_x * ChiL_x - ! dL_u/duc - Ju(1,0) = Ju(1,0) + (-du) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiL_x(xc,xr) - - ! dL_u/dur - Ju(1,1) = Ju(1,1) + (-du) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiR_x(xc,xr) - - ! L_v = -dv * v_x * ChiL_x - ! dL_v/dvc - Jv(2,0) = Jv(2,0) + (-dv) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiL_x(xc,xr) - - ! dL_v/dvr - Jv(2,1) = Jv(2,1) + (-dv) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiR_x(xc,xr) - - ! L_w = -dw * w_x * ChiL_x - ! dL_w/dwc - Jw(3,0) = Jw(3,0) + (-dw) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiL_x(xc,xr) - - ! dL_w/dwr - Jw(3,1) = Jw(3,1) + (-dw) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiR_x(xc,xr) - - - ! compute reaction Jacobian components - - ! R_u = (a - (w+1.d0)*u + v*u*u) - ! dR_u/duc - df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiL1 * ChiL1 - df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiL2 * ChiL2 - df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiL3 * ChiL3 - Ju(1,0) = Ju(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dur - df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiL1 * ChiR1 - df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiL2 * ChiR2 - df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiL3 * ChiR3 - Ju(1,1) = Ju(1,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dvc - df1 = (u1*u1) * ChiL1 * ChiL1 - df2 = (u2*u2) * ChiL2 * ChiL2 - df3 = (u3*u3) * ChiL3 * ChiL3 - Ju(2,0) = Ju(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dvr - df1 = (u1*u1) * ChiL1 * ChiR1 - df2 = (u2*u2) * ChiL2 * ChiR2 - df3 = (u3*u3) * ChiL3 * ChiR3 - Ju(2,1) = Ju(2,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dwc - df1 = (-u1) * ChiL1 * ChiL1 - df2 = (-u2) * ChiL2 * ChiL2 - df3 = (-u3) * ChiL3 * ChiL3 - Ju(3,0) = Ju(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_u/dwr - df1 = (-u1) * ChiL1 * ChiR1 - df2 = (-u2) * ChiL2 * ChiR2 - df3 = (-u3) * ChiL3 * ChiR3 - Ju(3,1) = Ju(3,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - - ! R_v = (w*u - v*u*u) - ! dR_v/duc - df1 = (w1 - 2.d0*v1*u1) * ChiL1 * ChiL1 - df2 = (w2 - 2.d0*v2*u2) * ChiL2 * ChiL2 - df3 = (w3 - 2.d0*v3*u3) * ChiL3 * ChiL3 - Jv(1,0) = Jv(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dur - df1 = (w1 - 2.d0*v1*u1) * ChiL1 * ChiR1 - df2 = (w2 - 2.d0*v2*u2) * ChiL2 * ChiR2 - df3 = (w3 - 2.d0*v3*u3) * ChiL3 * ChiR3 - Jv(1,1) = Jv(1,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dvc - df1 = (-u1*u1) * ChiL1 * ChiL1 - df2 = (-u2*u2) * ChiL2 * ChiL2 - df3 = (-u3*u3) * ChiL3 * ChiL3 - Jv(2,0) = Jv(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dvr - df1 = (-u1*u1) * ChiL1 * ChiR1 - df2 = (-u2*u2) * ChiL2 * ChiR2 - df3 = (-u3*u3) * ChiL3 * ChiR3 - Jv(2,1) = Jv(2,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dwc - df1 = (u1) * ChiL1 * ChiL1 - df2 = (u2) * ChiL2 * ChiL2 - df3 = (u3) * ChiL3 * ChiL3 - Jv(3,0) = Jv(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_v/dwr - df1 = (u1) * ChiL1 * ChiR1 - df2 = (u2) * ChiL2 * ChiR2 - df3 = (u3) * ChiL3 * ChiR3 - Jv(3,1) = Jv(3,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - - ! R_w = ((b-w)/ep - w*u) - ! dR_w/duc - df1 = (-w1) * ChiL1 * ChiL1 - df2 = (-w2) * ChiL2 * ChiL2 - df3 = (-w3) * ChiL3 * ChiL3 - Jw(1,0) = Jw(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_w/dur - df1 = (-w1) * ChiL1 * ChiR1 - df2 = (-w2) * ChiL2 * ChiR2 - df3 = (-w3) * ChiL3 * ChiR3 - Jw(1,1) = Jw(1,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_w/dwc - df1 = (-1.d0/ep - u1) * ChiL1 * ChiL1 - df2 = (-1.d0/ep - u2) * ChiL2 * ChiL2 - df3 = (-1.d0/ep - u3) * ChiL3 * ChiL3 - Jw(3,0) = Jw(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - ! dR_w/dwr - df1 = (-1.d0/ep - u1) * ChiL1 * ChiR1 - df2 = (-1.d0/ep - u2) * ChiL2 * ChiR2 - df3 = (-1.d0/ep - u3) * ChiL3 * ChiR3 - Jw(3,1) = Jw(3,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 - - - ! insert Jacobian entries into CSR matrix structure - - ! Ju row - Jrowptrs(idx(ix,1)+1) = nz - - Jdata(nz+1:nz+3) = (/ Ju(1,-1), Ju(2,-1), Ju(3,-1) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix-1,1), idx(ix-1,2), idx(ix-1,3) /) - nz = nz+3 - - Jdata(nz+1:nz+3) = (/ Ju(1,0), Ju(2,0), Ju(3,0) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix,1), idx(ix,2), idx(ix,3) /) - nz = nz+3 - - Jdata(nz+1:nz+3) = (/ Ju(1,1), Ju(2,1), Ju(3,1) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix+1,1), idx(ix+1,2), idx(ix+1,3) /) - nz = nz+3 - - ! Jv row - Jrowptrs(idx(ix,2)+1) = nz - - Jdata(nz+1:nz+3) = (/ Jv(1,-1), Jv(2,-1), Jv(3,-1) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix-1,1), idx(ix-1,2), idx(ix-1,3) /) - nz = nz+3 - - Jdata(nz+1:nz+3) = (/ Jv(1,0), Jv(2,0), Jv(3,0) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix,1), idx(ix,2), idx(ix,3) /) - nz = nz+3 - - Jdata(nz+1:nz+3) = (/ Jv(1,1), Jv(2,1), Jv(3,1) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix+1,1), idx(ix+1,2), idx(ix+1,3) /) - nz = nz+3 - - ! Jw row - Jrowptrs(idx(ix,3)+1) = nz - - Jdata(nz+1:nz+3) = (/ Jw(1,-1), Jw(2,-1), Jw(3,-1) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix-1,1), idx(ix-1,2), idx(ix-1,3) /) - nz = nz+3 - - Jdata(nz+1:nz+3) = (/ Jw(1,0), Jw(2,0), Jw(3,0) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix,1), idx(ix,2), idx(ix,3) /) - nz = nz+3 - - Jdata(nz+1:nz+3) = (/ Jw(1,1), Jw(2,1), Jw(3,1) /) - Jcolvals(nz+1:nz+3) = (/ idx(ix+1,1), idx(ix+1,2), idx(ix+1,3) /) - nz = nz+3 + do ix = 2, N - 1 + + ! set nodal value shortcuts (interval index aligns with left node) + xl = x(ix - 1) + ul = yvec(1, ix - 1) + vl = yvec(2, ix - 1) + wl = yvec(3, ix - 1) + xc = x(ix) + uc = yvec(1, ix) + vc = yvec(2, ix) + wc = yvec(3, ix) + xr = x(ix + 1) + ur = yvec(1, ix + 1) + vr = yvec(2, ix + 1) + wr = yvec(3, ix + 1) + + ! compute entries of all Jacobian rows at node ix + Ju = 0.d0 + Jv = 0.d0 + Jw = 0.d0 + + ! first compute dependence on values to left and center + + ! evaluate relevant variables in left subinterval + u1 = Eval(ul, uc, xl, xc, X1(xl, xc)) + v1 = Eval(vl, vc, xl, xc, X1(xl, xc)) + w1 = Eval(wl, wc, xl, xc, X1(xl, xc)) + u2 = Eval(ul, uc, xl, xc, X2(xl, xc)) + v2 = Eval(vl, vc, xl, xc, X2(xl, xc)) + w2 = Eval(wl, wc, xl, xc, X2(xl, xc)) + u3 = Eval(ul, uc, xl, xc, X3(xl, xc)) + v3 = Eval(vl, vc, xl, xc, X3(xl, xc)) + w3 = Eval(wl, wc, xl, xc, X3(xl, xc)) + + dQdf1 = Quad(1.d0, 0.d0, 0.d0, xl, xc) + dQdf2 = Quad(0.d0, 1.d0, 0.d0, xl, xc) + dQdf3 = Quad(0.d0, 0.d0, 1.d0, xl, xc) + + ChiL1 = ChiL(xl, xc, X1(xl, xc)) + ChiL2 = ChiL(xl, xc, X2(xl, xc)) + ChiL3 = ChiL(xl, xc, X3(xl, xc)) + ChiR1 = ChiR(xl, xc, X1(xl, xc)) + ChiR2 = ChiR(xl, xc, X2(xl, xc)) + ChiR3 = ChiR(xl, xc, X3(xl, xc)) + + ! compute diffusion Jacobian components + + ! L_u = -du * u_x * ChiR_x + ! dL_u/dul + Ju(1, -1) = (-du)*Quad(1.d0, 1.d0, 1.d0, xl, xc)*ChiL_x(xl, xc)*ChiR_x(xl, xc) + ! dL_u/duc + Ju(1, 0) = (-du)*Quad(1.d0, 1.d0, 1.d0, xl, xc)*ChiR_x(xl, xc)*ChiR_x(xl, xc) + + ! L_v = -dv * v_x * ChiR_x + ! dL_v/dvl + Jv(2, -1) = (-dv)*Quad(1.d0, 1.d0, 1.d0, xl, xc)*ChiL_x(xl, xc)*ChiR_x(xl, xc) + ! dL_v/dvc + Jv(2, 0) = (-dv)*Quad(1.d0, 1.d0, 1.d0, xl, xc)*ChiR_x(xl, xc)*ChiR_x(xl, xc) + + ! L_w = -dw * w_x * ChiR_x + ! dL_w/dwl + Jw(3, -1) = (-dw)*Quad(1.d0, 1.d0, 1.d0, xl, xc)*ChiL_x(xl, xc)*ChiR_x(xl, xc) + ! dL_w/dwc + Jw(3, 0) = (-dw)*Quad(1.d0, 1.d0, 1.d0, xl, xc)*ChiR_x(xl, xc)*ChiR_x(xl, xc) + + ! compute reaction Jacobian components + + ! R_u = (a - (w+1.d0)*u + v*u*u) + ! dR_u/dul + df1 = (-(w1 + 1.d0) + 2.d0*v1*u1)*ChiL1*ChiR1 + df2 = (-(w2 + 1.d0) + 2.d0*v2*u2)*ChiL2*ChiR2 + df3 = (-(w3 + 1.d0) + 2.d0*v3*u3)*ChiL3*ChiR3 + Ju(1, -1) = Ju(1, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/duc + df1 = (-(w1 + 1.d0) + 2.d0*v1*u1)*ChiR1*ChiR1 + df2 = (-(w2 + 1.d0) + 2.d0*v2*u2)*ChiR2*ChiR2 + df3 = (-(w3 + 1.d0) + 2.d0*v3*u3)*ChiR3*ChiR3 + Ju(1, 0) = Ju(1, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dvl + df1 = (u1*u1)*ChiL1*ChiR1 + df2 = (u2*u2)*ChiL2*ChiR2 + df3 = (u3*u3)*ChiL3*ChiR3 + Ju(2, -1) = Ju(2, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dvc + df1 = (u1*u1)*ChiR1*ChiR1 + df2 = (u2*u2)*ChiR2*ChiR2 + df3 = (u3*u3)*ChiR3*ChiR3 + Ju(2, 0) = Ju(2, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dwl + df1 = (-u1)*ChiL1*ChiR1 + df2 = (-u2)*ChiL2*ChiR2 + df3 = (-u3)*ChiL3*ChiR3 + Ju(3, -1) = Ju(3, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dwc + df1 = (-u1)*ChiR1*ChiR1 + df2 = (-u2)*ChiR2*ChiR2 + df3 = (-u3)*ChiR3*ChiR3 + Ju(3, 0) = Ju(3, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! R_v = (w*u - v*u*u) + ! dR_v/dul + df1 = (w1 - 2.d0*v1*u1)*ChiL1*ChiR1 + df2 = (w2 - 2.d0*v2*u2)*ChiL2*ChiR2 + df3 = (w3 - 2.d0*v3*u3)*ChiL3*ChiR3 + Jv(1, -1) = Jv(1, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/duc + df1 = (w1 - 2.d0*v1*u1)*ChiR1*ChiR1 + df2 = (w2 - 2.d0*v2*u2)*ChiR2*ChiR2 + df3 = (w3 - 2.d0*v3*u3)*ChiR3*ChiR3 + Jv(1, 0) = Jv(1, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dvl + df1 = (-u1*u1)*ChiL1*ChiR1 + df2 = (-u2*u2)*ChiL2*ChiR2 + df3 = (-u3*u3)*ChiL3*ChiR3 + Jv(2, -1) = Jv(2, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dvc + df1 = (-u1*u1)*ChiR1*ChiR1 + df2 = (-u2*u2)*ChiR2*ChiR2 + df3 = (-u3*u3)*ChiR3*ChiR3 + Jv(2, 0) = Jv(2, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dwl + df1 = (u1)*ChiL1*ChiR1 + df2 = (u2)*ChiL2*ChiR2 + df3 = (u3)*ChiL3*ChiR3 + Jv(3, -1) = Jv(3, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dwc + df1 = (u1)*ChiR1*ChiR1 + df2 = (u2)*ChiR2*ChiR2 + df3 = (u3)*ChiR3*ChiR3 + Jv(3, 0) = Jv(3, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! R_w = ((b-w)/ep - w*u) + ! dR_w/dul + df1 = (-w1)*ChiL1*ChiR1 + df2 = (-w2)*ChiL2*ChiR2 + df3 = (-w3)*ChiL3*ChiR3 + Jw(1, -1) = Jw(1, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_w/duc + df1 = (-w1)*ChiR1*ChiR1 + df2 = (-w2)*ChiR2*ChiR2 + df3 = (-w3)*ChiR3*ChiR3 + Jw(1, 0) = Jw(1, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_w/dwl + df1 = (-1.d0/ep - u1)*ChiL1*ChiR1 + df2 = (-1.d0/ep - u2)*ChiL2*ChiR2 + df3 = (-1.d0/ep - u3)*ChiL3*ChiR3 + Jw(3, -1) = Jw(3, -1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_w/dwc + df1 = (-1.d0/ep - u1)*ChiR1*ChiR1 + df2 = (-1.d0/ep - u2)*ChiR2*ChiR2 + df3 = (-1.d0/ep - u3)*ChiR3*ChiR3 + Jw(3, 0) = Jw(3, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! second compute dependence on values to center and right + + ! evaluate relevant variables in right subinterval + u1 = Eval(uc, ur, xc, xr, X1(xc, xr)) + v1 = Eval(vc, vr, xc, xr, X1(xc, xr)) + w1 = Eval(wc, wr, xc, xr, X1(xc, xr)) + u2 = Eval(uc, ur, xc, xr, X2(xc, xr)) + v2 = Eval(vc, vr, xc, xr, X2(xc, xr)) + w2 = Eval(wc, wr, xc, xr, X2(xc, xr)) + u3 = Eval(uc, ur, xc, xr, X3(xc, xr)) + v3 = Eval(vc, vr, xc, xr, X3(xc, xr)) + w3 = Eval(wc, wr, xc, xr, X3(xc, xr)) + + dQdf1 = Quad(1.d0, 0.d0, 0.d0, xc, xr) + dQdf2 = Quad(0.d0, 1.d0, 0.d0, xc, xr) + dQdf3 = Quad(0.d0, 0.d0, 1.d0, xc, xr) + + ChiL1 = ChiL(xc, xr, X1(xc, xr)) + ChiL2 = ChiL(xc, xr, X2(xc, xr)) + ChiL3 = ChiL(xc, xr, X3(xc, xr)) + ChiR1 = ChiR(xc, xr, X1(xc, xr)) + ChiR2 = ChiR(xc, xr, X2(xc, xr)) + ChiR3 = ChiR(xc, xr, X3(xc, xr)) + + ! compute diffusion Jacobian components + + ! L_u = -du * u_x * ChiL_x + ! dL_u/duc + Ju(1, 0) = Ju(1, 0) + (-du)*Quad(1.d0, 1.d0, 1.d0, xc, xr)*ChiL_x(xc, xr)*ChiL_x(xc, xr) + + ! dL_u/dur + Ju(1, 1) = Ju(1, 1) + (-du)*Quad(1.d0, 1.d0, 1.d0, xc, xr)*ChiL_x(xc, xr)*ChiR_x(xc, xr) + + ! L_v = -dv * v_x * ChiL_x + ! dL_v/dvc + Jv(2, 0) = Jv(2, 0) + (-dv)*Quad(1.d0, 1.d0, 1.d0, xc, xr)*ChiL_x(xc, xr)*ChiL_x(xc, xr) + + ! dL_v/dvr + Jv(2, 1) = Jv(2, 1) + (-dv)*Quad(1.d0, 1.d0, 1.d0, xc, xr)*ChiL_x(xc, xr)*ChiR_x(xc, xr) + + ! L_w = -dw * w_x * ChiL_x + ! dL_w/dwc + Jw(3, 0) = Jw(3, 0) + (-dw)*Quad(1.d0, 1.d0, 1.d0, xc, xr)*ChiL_x(xc, xr)*ChiL_x(xc, xr) + + ! dL_w/dwr + Jw(3, 1) = Jw(3, 1) + (-dw)*Quad(1.d0, 1.d0, 1.d0, xc, xr)*ChiL_x(xc, xr)*ChiR_x(xc, xr) + + ! compute reaction Jacobian components + + ! R_u = (a - (w+1.d0)*u + v*u*u) + ! dR_u/duc + df1 = (-(w1 + 1.d0) + 2.d0*v1*u1)*ChiL1*ChiL1 + df2 = (-(w2 + 1.d0) + 2.d0*v2*u2)*ChiL2*ChiL2 + df3 = (-(w3 + 1.d0) + 2.d0*v3*u3)*ChiL3*ChiL3 + Ju(1, 0) = Ju(1, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dur + df1 = (-(w1 + 1.d0) + 2.d0*v1*u1)*ChiL1*ChiR1 + df2 = (-(w2 + 1.d0) + 2.d0*v2*u2)*ChiL2*ChiR2 + df3 = (-(w3 + 1.d0) + 2.d0*v3*u3)*ChiL3*ChiR3 + Ju(1, 1) = Ju(1, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dvc + df1 = (u1*u1)*ChiL1*ChiL1 + df2 = (u2*u2)*ChiL2*ChiL2 + df3 = (u3*u3)*ChiL3*ChiL3 + Ju(2, 0) = Ju(2, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dvr + df1 = (u1*u1)*ChiL1*ChiR1 + df2 = (u2*u2)*ChiL2*ChiR2 + df3 = (u3*u3)*ChiL3*ChiR3 + Ju(2, 1) = Ju(2, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dwc + df1 = (-u1)*ChiL1*ChiL1 + df2 = (-u2)*ChiL2*ChiL2 + df3 = (-u3)*ChiL3*ChiL3 + Ju(3, 0) = Ju(3, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_u/dwr + df1 = (-u1)*ChiL1*ChiR1 + df2 = (-u2)*ChiL2*ChiR2 + df3 = (-u3)*ChiL3*ChiR3 + Ju(3, 1) = Ju(3, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! R_v = (w*u - v*u*u) + ! dR_v/duc + df1 = (w1 - 2.d0*v1*u1)*ChiL1*ChiL1 + df2 = (w2 - 2.d0*v2*u2)*ChiL2*ChiL2 + df3 = (w3 - 2.d0*v3*u3)*ChiL3*ChiL3 + Jv(1, 0) = Jv(1, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dur + df1 = (w1 - 2.d0*v1*u1)*ChiL1*ChiR1 + df2 = (w2 - 2.d0*v2*u2)*ChiL2*ChiR2 + df3 = (w3 - 2.d0*v3*u3)*ChiL3*ChiR3 + Jv(1, 1) = Jv(1, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dvc + df1 = (-u1*u1)*ChiL1*ChiL1 + df2 = (-u2*u2)*ChiL2*ChiL2 + df3 = (-u3*u3)*ChiL3*ChiL3 + Jv(2, 0) = Jv(2, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dvr + df1 = (-u1*u1)*ChiL1*ChiR1 + df2 = (-u2*u2)*ChiL2*ChiR2 + df3 = (-u3*u3)*ChiL3*ChiR3 + Jv(2, 1) = Jv(2, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dwc + df1 = (u1)*ChiL1*ChiL1 + df2 = (u2)*ChiL2*ChiL2 + df3 = (u3)*ChiL3*ChiL3 + Jv(3, 0) = Jv(3, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_v/dwr + df1 = (u1)*ChiL1*ChiR1 + df2 = (u2)*ChiL2*ChiR2 + df3 = (u3)*ChiL3*ChiR3 + Jv(3, 1) = Jv(3, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! R_w = ((b-w)/ep - w*u) + ! dR_w/duc + df1 = (-w1)*ChiL1*ChiL1 + df2 = (-w2)*ChiL2*ChiL2 + df3 = (-w3)*ChiL3*ChiL3 + Jw(1, 0) = Jw(1, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_w/dur + df1 = (-w1)*ChiL1*ChiR1 + df2 = (-w2)*ChiL2*ChiR2 + df3 = (-w3)*ChiL3*ChiR3 + Jw(1, 1) = Jw(1, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_w/dwc + df1 = (-1.d0/ep - u1)*ChiL1*ChiL1 + df2 = (-1.d0/ep - u2)*ChiL2*ChiL2 + df3 = (-1.d0/ep - u3)*ChiL3*ChiL3 + Jw(3, 0) = Jw(3, 0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! dR_w/dwr + df1 = (-1.d0/ep - u1)*ChiL1*ChiR1 + df2 = (-1.d0/ep - u2)*ChiL2*ChiR2 + df3 = (-1.d0/ep - u3)*ChiL3*ChiR3 + Jw(3, 1) = Jw(3, 1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3 + + ! insert Jacobian entries into CSR matrix structure + + ! Ju row + Jrowptrs(idx(ix, 1) + 1) = nz + + Jdata(nz + 1:nz + 3) = (/Ju(1, -1), Ju(2, -1), Ju(3, -1)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix - 1, 1), idx(ix - 1, 2), idx(ix - 1, 3)/) + nz = nz + 3 + + Jdata(nz + 1:nz + 3) = (/Ju(1, 0), Ju(2, 0), Ju(3, 0)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix, 1), idx(ix, 2), idx(ix, 3)/) + nz = nz + 3 + + Jdata(nz + 1:nz + 3) = (/Ju(1, 1), Ju(2, 1), Ju(3, 1)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix + 1, 1), idx(ix + 1, 2), idx(ix + 1, 3)/) + nz = nz + 3 + + ! Jv row + Jrowptrs(idx(ix, 2) + 1) = nz + + Jdata(nz + 1:nz + 3) = (/Jv(1, -1), Jv(2, -1), Jv(3, -1)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix - 1, 1), idx(ix - 1, 2), idx(ix - 1, 3)/) + nz = nz + 3 + + Jdata(nz + 1:nz + 3) = (/Jv(1, 0), Jv(2, 0), Jv(3, 0)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix, 1), idx(ix, 2), idx(ix, 3)/) + nz = nz + 3 + + Jdata(nz + 1:nz + 3) = (/Jv(1, 1), Jv(2, 1), Jv(3, 1)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix + 1, 1), idx(ix + 1, 2), idx(ix + 1, 3)/) + nz = nz + 3 + + ! Jw row + Jrowptrs(idx(ix, 3) + 1) = nz + + Jdata(nz + 1:nz + 3) = (/Jw(1, -1), Jw(2, -1), Jw(3, -1)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix - 1, 1), idx(ix - 1, 2), idx(ix - 1, 3)/) + nz = nz + 3 + + Jdata(nz + 1:nz + 3) = (/Jw(1, 0), Jw(2, 0), Jw(3, 0)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix, 1), idx(ix, 2), idx(ix, 3)/) + nz = nz + 3 + + Jdata(nz + 1:nz + 3) = (/Jw(1, 1), Jw(2, 1), Jw(3, 1)/) + Jcolvals(nz + 1:nz + 3) = (/idx(ix + 1, 1), idx(ix + 1, 2), idx(ix + 1, 3)/) + nz = nz + 3 end do ! Dirichlet boundary at right - Jrowptrs(idx(Nint,1)+1) = nz - Jrowptrs(idx(Nint,2)+1) = nz - Jrowptrs(idx(Nint,3)+1) = nz + Jrowptrs(idx(Nint, 1) + 1) = nz + Jrowptrs(idx(Nint, 2) + 1) = nz + Jrowptrs(idx(Nint, 3) + 1) = nz ! signal end of data in CSR matrix - Jrowptrs(idx(Nint,3)+2) = nz + Jrowptrs(idx(Nint, 3) + 2) = nz ! return success ierr = 0 @@ -844,12 +833,11 @@ integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & end function Jac ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Mass matrix computation routine ! ---------------------------------------------------------------- integer(c_int) function Mass(tn, sunmat_M, user_data, & - sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) bind(C,name='Mass') + sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) bind(C, name='Mass') !======= Inclusions =========== use FEMBasis @@ -863,7 +851,7 @@ integer(c_int) function Mass(tn, sunmat_M, user_data, & ! calling variables real(c_double), value :: tn ! current time type(SUNMatrix) :: sunmat_M ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 @@ -875,19 +863,19 @@ integer(c_int) function Mass(tn, sunmat_M, user_data, & ! pointers to data in SUNDIALS vectors integer(c_int64_t), pointer, dimension(nnz) :: Mcolvals(:) - integer(c_int64_t), pointer, dimension(neq+1) :: Mrowptrs(:) - real(c_double), pointer, dimension(nnz) :: Mdata(:) + integer(c_int64_t), pointer, dimension(neq + 1) :: Mrowptrs(:) + real(c_double), pointer, dimension(nnz) :: Mdata(:) !======= Internals ============ ! get data arrays from SUNDIALS vectors - Mdata(1:nnz) => FSUNSparseMatrix_Data(sunmat_M) - Mcolvals(1:nnz) => FSUNSparseMatrix_IndexValues(sunmat_M) - Mrowptrs(1:neq+1) => FSUNSparseMatrix_IndexPointers(sunmat_M) + Mdata(1:nnz) => FSUNSparseMatrix_Data(sunmat_M) + Mcolvals(1:nnz) => FSUNSparseMatrix_IndexValues(sunmat_M) + Mrowptrs(1:neq + 1) => FSUNSparseMatrix_IndexPointers(sunmat_M) ! check that vector/matrix dimensions match up if ((3*N /= neq) .or. (nnz /= 15*neq)) then - ierr = 1 - return + ierr = 1 + return end if ! set integer*4 version of N for call to idx() @@ -898,113 +886,112 @@ integer(c_int) function Mass(tn, sunmat_M, user_data, & nz = 0 ! iterate through nodes, filling in matrix by rows - do ix=1,N - - ! set booleans to determine whether intervals exist on the left/right */ - left = .true. - right = .true. - if (ix==1) left = .false. - if (ix==N) right = .false. - - ! set nodal value shortcuts (interval index aligns with left node) - if (left) then - xl = x(ix-1) - end if - xc = x(ix) - if (right) then - xr = x(ix+1) - end if - - ! compute entries of all mass matrix rows at node ix - Ml = 0.d0 - Mc = 0.d0 - Mr = 0.d0 - - ! first compute dependence on values to left and center - if (left) then - - ChiL1 = ChiL(xl, xc, X1(xl,xc)) - ChiL2 = ChiL(xl, xc, X2(xl,xc)) - ChiL3 = ChiL(xl, xc, X3(xl,xc)) - ChiR1 = ChiR(xl, xc, X1(xl,xc)) - ChiR2 = ChiR(xl, xc, X2(xl,xc)) - ChiR3 = ChiR(xl, xc, X3(xl,xc)) - - Ml = Ml + Quad(ChiL1*ChiR1, ChiL2*ChiR2, ChiL3*ChiR3, xl, xc) - Mc = Mc + Quad(ChiR1*ChiR1, ChiR2*ChiR2, ChiR3*ChiR3, xl, xc) - - end if - - ! second compute dependence on values to center and right - if (right) then - - ChiL1 = ChiL(xc, xr, X1(xc,xr)) - ChiL2 = ChiL(xc, xr, X2(xc,xr)) - ChiL3 = ChiL(xc, xr, X3(xc,xr)) - ChiR1 = ChiR(xc, xr, X1(xc,xr)) - ChiR2 = ChiR(xc, xr, X2(xc,xr)) - ChiR3 = ChiR(xc, xr, X3(xc,xr)) - - Mc = Mc + Quad(ChiL1*ChiL1, ChiL2*ChiL2, ChiL3*ChiL3, xc, xr) - Mr = Mr + Quad(ChiL1*ChiR1, ChiL2*ChiR2, ChiL3*ChiR3, xc, xr) - - end if - - - ! insert mass matrix entries into CSR matrix structure - - ! u row - Mrowptrs(idx(ix,1)+1) = nz - if (left) then - nz = nz+1 - Mdata(nz) = Ml - Mcolvals(nz) = idx(ix-1,1) - end if - nz = nz+1 - Mdata(nz) = Mc - Mcolvals(nz) = idx(ix,1) - if (right) then - nz = nz+1 - Mdata(nz) = Mr - Mcolvals(nz) = idx(ix+1,1) - end if - - ! v row - Mrowptrs(idx(ix,2)+1) = nz - if (left) then - nz = nz+1 - Mdata(nz) = Ml - Mcolvals(nz) = idx(ix-1,2) - end if - nz = nz+1 - Mdata(nz) = Mc - Mcolvals(nz) = idx(ix,2) - if (right) then - nz = nz+1 - Mdata(nz) = Mr - Mcolvals(nz) = idx(ix+1,2) - end if - - ! w row - Mrowptrs(idx(ix,3)+1) = nz - if (left) then - nz = nz+1 - Mdata(nz) = Ml - Mcolvals(nz) = idx(ix-1,3) - end if - nz = nz+1 - Mdata(nz) = Mc - Mcolvals(nz) = idx(ix,3) - if (right) then - nz = nz+1 - Mdata(nz) = Mr - Mcolvals(nz) = idx(ix+1,3) - end if + do ix = 1, N + + ! set booleans to determine whether intervals exist on the left/right */ + left = .true. + right = .true. + if (ix == 1) left = .false. + if (ix == N) right = .false. + + ! set nodal value shortcuts (interval index aligns with left node) + if (left) then + xl = x(ix - 1) + end if + xc = x(ix) + if (right) then + xr = x(ix + 1) + end if + + ! compute entries of all mass matrix rows at node ix + Ml = 0.d0 + Mc = 0.d0 + Mr = 0.d0 + + ! first compute dependence on values to left and center + if (left) then + + ChiL1 = ChiL(xl, xc, X1(xl, xc)) + ChiL2 = ChiL(xl, xc, X2(xl, xc)) + ChiL3 = ChiL(xl, xc, X3(xl, xc)) + ChiR1 = ChiR(xl, xc, X1(xl, xc)) + ChiR2 = ChiR(xl, xc, X2(xl, xc)) + ChiR3 = ChiR(xl, xc, X3(xl, xc)) + + Ml = Ml + Quad(ChiL1*ChiR1, ChiL2*ChiR2, ChiL3*ChiR3, xl, xc) + Mc = Mc + Quad(ChiR1*ChiR1, ChiR2*ChiR2, ChiR3*ChiR3, xl, xc) + + end if + + ! second compute dependence on values to center and right + if (right) then + + ChiL1 = ChiL(xc, xr, X1(xc, xr)) + ChiL2 = ChiL(xc, xr, X2(xc, xr)) + ChiL3 = ChiL(xc, xr, X3(xc, xr)) + ChiR1 = ChiR(xc, xr, X1(xc, xr)) + ChiR2 = ChiR(xc, xr, X2(xc, xr)) + ChiR3 = ChiR(xc, xr, X3(xc, xr)) + + Mc = Mc + Quad(ChiL1*ChiL1, ChiL2*ChiL2, ChiL3*ChiL3, xc, xr) + Mr = Mr + Quad(ChiL1*ChiR1, ChiL2*ChiR2, ChiL3*ChiR3, xc, xr) + + end if + + ! insert mass matrix entries into CSR matrix structure + + ! u row + Mrowptrs(idx(ix, 1) + 1) = nz + if (left) then + nz = nz + 1 + Mdata(nz) = Ml + Mcolvals(nz) = idx(ix - 1, 1) + end if + nz = nz + 1 + Mdata(nz) = Mc + Mcolvals(nz) = idx(ix, 1) + if (right) then + nz = nz + 1 + Mdata(nz) = Mr + Mcolvals(nz) = idx(ix + 1, 1) + end if + + ! v row + Mrowptrs(idx(ix, 2) + 1) = nz + if (left) then + nz = nz + 1 + Mdata(nz) = Ml + Mcolvals(nz) = idx(ix - 1, 2) + end if + nz = nz + 1 + Mdata(nz) = Mc + Mcolvals(nz) = idx(ix, 2) + if (right) then + nz = nz + 1 + Mdata(nz) = Mr + Mcolvals(nz) = idx(ix + 1, 2) + end if + + ! w row + Mrowptrs(idx(ix, 3) + 1) = nz + if (left) then + nz = nz + 1 + Mdata(nz) = Ml + Mcolvals(nz) = idx(ix - 1, 3) + end if + nz = nz + 1 + Mdata(nz) = Mc + Mcolvals(nz) = idx(ix, 3) + if (right) then + nz = nz + 1 + Mdata(nz) = Mr + Mcolvals(nz) = idx(ix + 1, 3) + end if end do ! signal end of data in CSR matrix - Mrowptrs(idx(Nint,3)+2) = nz + Mrowptrs(idx(Nint, 3) + 2) = nz ! return success ierr = 0 @@ -1016,7 +1003,6 @@ end function Mass end module bruss1D_ode_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -1053,20 +1039,20 @@ program main integer(c_long) :: mxsteps ! max num steps integer(c_int64_t) :: i - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(N_Vector), pointer :: sunvec_u ! sundials vector - type(N_Vector), pointer :: sunvec_v ! sundials vector - type(N_Vector), pointer :: sunvec_w ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials (linsol) matrix - type(SUNMatrix), pointer :: sunmat_M ! sundials (mass) matrix + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(N_Vector), pointer :: sunvec_u ! sundials vector + type(N_Vector), pointer :: sunvec_v ! sundials vector + type(N_Vector), pointer :: sunvec_w ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials (linsol) matrix + type(SUNMatrix), pointer :: sunmat_M ! sundials (mass) matrix type(SUNLinearSolver), pointer :: sunls_A ! sundials linear solver type(SUNLinearSolver), pointer :: sunls_M ! sundials linear solver type(c_ptr) :: arkode_mem ! ARKODE memory type(c_ptr) :: outstr ! standard output file stream - real(c_double), pointer, dimension(neqreal,N) :: yvec(:,:) ! underlying vector y - real(c_double), pointer, dimension(neqreal,N) :: umask(:,:) ! identifier for u - real(c_double), pointer, dimension(neqreal,N) :: vmask(:,:) ! identifier for v - real(c_double), pointer, dimension(neqreal,N) :: wmask(:,:) ! identifier for w + real(c_double), pointer, dimension(neqreal, N) :: yvec(:, :) ! underlying vector y + real(c_double), pointer, dimension(neqreal, N) :: umask(:, :) ! identifier for u + real(c_double), pointer, dimension(neqreal, N) :: vmask(:, :) ! identifier for v + real(c_double), pointer, dimension(neqreal, N) :: wmask(:, :) ! identifier for w !======= Internals ============ @@ -1075,127 +1061,127 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 10.0d0 - tcur = tstart - tout = tstart - dtout = (tend - tstart)/10.d0 - nout = ceiling(tend/dtout) + tend = 10.0d0 + tcur = tstart + tout = tstart + dtout = (tend - tstart)/10.d0 + nout = ceiling(tend/dtout) ! create and assign SUNDIALS N_Vectors sunvec_y => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - yvec(1:neqreal,1:N) => FN_VGetArrayPointer(sunvec_y) + yvec(1:neqreal, 1:N) => FN_VGetArrayPointer(sunvec_y) sunvec_u => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - umask(1:neqreal,1:N) => FN_VGetArrayPointer(sunvec_u) + umask(1:neqreal, 1:N) => FN_VGetArrayPointer(sunvec_u) sunvec_v => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_v)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - vmask(1:neqreal,1:N) => FN_VGetArrayPointer(sunvec_v) + vmask(1:neqreal, 1:N) => FN_VGetArrayPointer(sunvec_v) sunvec_w => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_w)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - wmask(1:neqreal,1:N) => FN_VGetArrayPointer(sunvec_w) + wmask(1:neqreal, 1:N) => FN_VGetArrayPointer(sunvec_w) ! set up spatial mesh; this [arbitrarily] clusters ! more intervals near the end points of the interval pi = 4.d0*atan(1.d0) h = 10.d0/(N - 1) - do i=1,N - z = -5.d0 + h*(i - 1) - x(i) = 0.5d0/atan(5.d0)*atan(z) + 0.5d0 + do i = 1, N + z = -5.d0 + h*(i - 1) + x(i) = 0.5d0/atan(5.d0)*atan(z) + 0.5d0 end do ! output mesh to disk - open(200, file='bruss_FEM_mesh.txt') - do i=1,N - write(200,*) x(i) + open (200, file='bruss_FEM_mesh.txt') + do i = 1, N + write (200, *) x(i) end do - close(200) + close (200) ! set initial conditions into yvec - do i=1,N - yvec(1,i) = a + 0.1d0*sin(pi*x(i)) ! u0 - yvec(2,i) = b/a + 0.1d0*sin(pi*x(i)) ! v0 - yvec(3,i) = b + 0.1d0*sin(pi*x(i)) ! w0 + do i = 1, N + yvec(1, i) = a + 0.1d0*sin(pi*x(i)) ! u0 + yvec(2, i) = b/a + 0.1d0*sin(pi*x(i)) ! v0 + yvec(3, i) = b + 0.1d0*sin(pi*x(i)) ! w0 end do ! set mask values for each solution component umask = 0.d0 vmask = 0.d0 wmask = 0.d0 - do i=1,N - umask(1,i) = 1.d0 - vmask(2,i) = 1.d0 - wmask(3,i) = 1.d0 + do i = 1, N + umask(1, i) = 1.d0 + vmask(2, i) = 1.d0 + wmask(3, i) = 1.d0 end do ! create ARKStep memory arkode_mem = FARKStepCreate(c_null_funptr, c_funloc(ImpRhsFn), tstart, sunvec_y, ctx) - if (.not. c_associated(arkode_mem)) print *,'ERROR: arkode_mem = NULL' + if (.not. c_associated(arkode_mem)) print *, 'ERROR: arkode_mem = NULL' ! Tell ARKODE to use a sparse linear solver for both Newton and mass matrix systems. sparsetype = 1 sunmat_A => FSUNSparseMatrix(neq, neq, nnz, sparsetype, ctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat_A = NULL' - stop 1 + print *, 'ERROR: sunmat_A = NULL' + stop 1 end if sunmat_M => FSUNSparseMatrix(neq, neq, nnz, sparsetype, ctx) if (.not. associated(sunmat_M)) then - print *, 'ERROR: sunmat_M = NULL' - stop 1 + print *, 'ERROR: sunmat_M = NULL' + stop 1 end if sunls_A => FSUNLinSol_KLU(sunvec_y, sunmat_A, ctx) if (.not. associated(sunls_A)) then - print *, 'ERROR: sunls_A = NULL' - stop 1 + print *, 'ERROR: sunls_A = NULL' + stop 1 end if ierr = FARKodeSetLinearSolver(arkode_mem, sunls_A, sunmat_A) if (ierr /= 0) then - print *, 'Error in FARKodeSetLinearSolver' - stop 1 + print *, 'Error in FARKodeSetLinearSolver' + stop 1 end if ierr = FARKodeSetJacFn(arkode_mem, c_funloc(Jac)) if (ierr /= 0) then - print *, 'Error in FARKodeSetJacFn' - stop 1 + print *, 'Error in FARKodeSetJacFn' + stop 1 end if sunls_M => FSUNLinSol_KLU(sunvec_y, sunmat_M, ctx) if (.not. associated(sunls_M)) then - print *, 'ERROR: sunls_M = NULL' - stop 1 + print *, 'ERROR: sunls_M = NULL' + stop 1 end if time_dep = 0 ierr = FARKodeSetMassLinearSolver(arkode_mem, sunls_M, sunmat_M, time_dep) if (ierr /= 0) then - print *, 'Error in FARKodeSetMassLinearSolver' - stop 1 + print *, 'Error in FARKodeSetMassLinearSolver' + stop 1 end if ierr = FARKodeSetMassFn(arkode_mem, c_funloc(Mass)) if (ierr /= 0) then - print *, 'Error in FARKodeSetMassFn' - stop 1 + print *, 'Error in FARKodeSetMassFn' + stop 1 end if ! set relative and absolute tolerances @@ -1204,50 +1190,50 @@ program main ierr = FARKodeSStolerances(arkode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! set residual tolerance with the same atol as above ierr = FARKodeResStolerance(arkode_mem, atol) if (ierr /= 0) then - print *, 'Error in FARKodeResStolerance, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeResStolerance, ierr = ', ierr, '; halting' + stop 1 end if ! Set maximum number of internal time steps mxsteps = 1000 ierr = FARKodeSetMaxNumSteps(arkode_mem, mxsteps) if (ierr /= 0) then - print *, 'Error in FARKodeSetNonlinConvCoef' - stop 1 + print *, 'Error in FARKodeSetNonlinConvCoef' + stop 1 end if ! Open output stream for results - open(501, file='bruss_FEM_u.txt') - open(502, file='bruss_FEM_v.txt') - open(503, file='bruss_FEM_w.txt') + open (501, file='bruss_FEM_u.txt') + open (502, file='bruss_FEM_v.txt') + open (503, file='bruss_FEM_w.txt') ! output initial condition to disk - write(501,*) ( yvec(1,i), i=1,N ) - write(502,*) ( yvec(2,i), i=1,N ) - write(503,*) ( yvec(3,i), i=1,N ) + write (501, *) (yvec(1, i), i=1, N) + write (502, *) (yvec(2, i), i=1, N) + write (503, *) (yvec(3, i), i=1, N) ! output solver parameters to screen ierr = FSUNDIALSFileOpen('stdout', 'w', outstr) if (ierr /= 0) then - print *, 'Error in FSUNDIALSFileOpen' - stop 1 + print *, 'Error in FSUNDIALSFileOpen' + stop 1 end if ierr = FARKodeWriteParameters(arkode_mem, outstr) if (ierr /= 0) then - print *, 'Error in FARKodeWriteParameters' - stop 1 + print *, 'Error in FARKodeWriteParameters' + stop 1 end if ierr = FSUNDIALSFileClose(outstr) if (ierr /= 0) then - print *, 'Error in FSUNDIALSFileClose' - stop 1 + print *, 'Error in FSUNDIALSFileClose' + stop 1 end if ! Start time stepping @@ -1257,37 +1243,37 @@ program main print *, ' t ||u||_rms ||v||_rms ||w||_rms' print *, ' ----------------------------------------------------' print '(3x,4(es12.5,1x))', tcur, sqrt(sum(yvec*yvec*umask)/N), & - sqrt(sum(yvec*yvec*vmask)/N), sqrt(sum(yvec*yvec*wmask)/N) - do outstep = 1,nout - - ! set the next output time - tout = min(tout + dtout, tend) - - ierr = FARKodeSetStopTime(arkode_mem, tout) - if (ierr /= 0) then - print *, 'Error in FARKodeSetStopTime, ierr = ', ierr, '; halting' - stop 1 - end if - - ! call ARKodeEvolve - ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) - if (ierr < 0) then - print *, 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' - stop 1 - end if - - ! output current solution information (using yvec) - print '(3x,4(es12.5,1x))', Tcur, sqrt(sum(yvec*yvec*umask)/N), & - sqrt(sum(yvec*yvec*vmask)/N), sqrt(sum(yvec*yvec*wmask)/N) - write(501,*) ( yvec(1,i), i=1,N ) - write(502,*) ( yvec(2,i), i=1,N ) - write(503,*) ( yvec(3,i), i=1,N ) + sqrt(sum(yvec*yvec*vmask)/N), sqrt(sum(yvec*yvec*wmask)/N) + do outstep = 1, nout + + ! set the next output time + tout = min(tout + dtout, tend) + + ierr = FARKodeSetStopTime(arkode_mem, tout) + if (ierr /= 0) then + print *, 'Error in FARKodeSetStopTime, ierr = ', ierr, '; halting' + stop 1 + end if + + ! call ARKodeEvolve + ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) + if (ierr < 0) then + print *, 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' + stop 1 + end if + + ! output current solution information (using yvec) + print '(3x,4(es12.5,1x))', Tcur, sqrt(sum(yvec*yvec*umask)/N), & + sqrt(sum(yvec*yvec*vmask)/N), sqrt(sum(yvec*yvec*wmask)/N) + write (501, *) (yvec(1, i), i=1, N) + write (502, *) (yvec(2, i), i=1, N) + write (503, *) (yvec(3, i), i=1, N) end do print *, ' ----------------------------------------------------' - close(501) - close(502) - close(503) + close (501) + close (502) + close (503) ! diagnostics output call ARKStepStats(arkode_mem) @@ -1307,7 +1293,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! ARKStepStats ! @@ -1347,91 +1332,91 @@ subroutine ARKStepStats(arkode_mem) ierr = FARKodeGetNumSteps(arkode_mem, nsteps) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumSteps, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumStepAttempts, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumStepAttempts, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (ierr /= 0) then - print *, 'Error in FARKStepGetNumRhsEvals, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKStepGetNumRhsEvals, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetLastStep(arkode_mem, hlast) if (ierr /= 0) then - print *, 'Error in FARKodeGetLastStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetLastStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetCurrentStep(arkode_mem, hcur) if (ierr /= 0) then - print *, 'Error in FARKodeGetCurrentStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetCurrentTime(arkode_mem, tcur) if (ierr /= 0) then - print *, 'Error in FARKodeGetCurrentTime, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentTime, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumLinSolvSetups(arkode_mem, nlinsetups) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumErrTestFails(arkode_mem, netfails) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumErrTestFails, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumErrTestFails, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvIters(arkode_mem, nniters) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvConvFails(arkode_mem, nncfails) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumJacEvals(arkode_mem, njacevals) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumJacEvals, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumJacEvals, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumMassSetups(arkode_mem, nmassevals) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumMassSetups, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumMassSetups, retval = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total internal steps attempts =',nst_a - print '(4x,A,i9)' ,'Total rhs exp function calls =',nfe - print '(4x,A,i9)' ,'Total rhs imp function calls =',nfi - print '(4x,A,i9)' ,'Total jac function calls =',njacevals - print '(4x,A,i9)' ,'Total mass function calls =',nmassevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total internal steps attempts =', nst_a + print '(4x,A,i9)', 'Total rhs exp function calls =', nfe + print '(4x,A,i9)', 'Total rhs imp function calls =', nfi + print '(4x,A,i9)', 'Total jac function calls =', njacevals + print '(4x,A,i9)', 'Total mass function calls =', nmassevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/arkode/F2003_serial/ark_bruss_f2003.f90 b/examples/arkode/F2003_serial/ark_bruss_f2003.f90 index d4b5185105..2b6579cf20 100644 --- a/examples/arkode/F2003_serial/ark_bruss_f2003.f90 +++ b/examples/arkode/F2003_serial/ark_bruss_f2003.f90 @@ -60,7 +60,7 @@ module bruss_mod integer(kind=myindextype), parameter :: neq = 3 ! ODE parameters - real(c_double), parameter, dimension(neq) :: y0 = (/ 3.9d0, 1.1d0, 2.8d0 /) + real(c_double), parameter, dimension(neq) :: y0 = (/3.9d0, 1.1d0, 2.8d0/) real(c_double), parameter :: a = 1.2d0 real(c_double), parameter :: b = 2.5d0 real(c_double), parameter :: ep = 1.d-5 @@ -79,7 +79,7 @@ module bruss_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function ExpRhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -91,7 +91,7 @@ integer(c_int) function ExpRhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local data real(c_double) :: u, v, w @@ -123,7 +123,6 @@ integer(c_int) function ExpRhsFn(tn, sunvec_y, sunvec_f, user_data) & end function ExpRhsFn ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! ImpRhsFn provides the right hand side implicit function for the ! ODE: dy1/dt = f1(t,y1,y2,y3) @@ -136,7 +135,7 @@ end function ExpRhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -148,7 +147,7 @@ integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local data real(c_double) :: u, v, w @@ -171,7 +170,7 @@ integer(c_int) function ImpRhsFn(tn, sunvec_y, sunvec_f, user_data) & ! fill RHS vector fvec(1) = 0.d0 fvec(2) = 0.d0 - fvec(3) = (b-w)/ep + fvec(3) = (b - w)/ep ! return success ierr = 0 @@ -189,7 +188,7 @@ end function ImpRhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & - sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) bind(C,name='Jac') + sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) bind(C, name='Jac') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -203,13 +202,13 @@ integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 ! pointers to data in SUNDIALS vector and matrix - real(c_double), pointer, dimension(neq,neq) :: J(:,:) + real(c_double), pointer, dimension(neq, neq) :: J(:, :) !======= Internals ============ @@ -218,7 +217,7 @@ integer(c_int) function Jac(tn, sunvec_y, sunvec_f, sunmat_J, user_data, & ! fill Jacobian entries J(1:3, 1:3) = 0.d0 - J(3,3) = -1.d0/ep + J(3, 3) = -1.d0/ep ! return success ierr = 0 @@ -230,7 +229,6 @@ end function Jac end module bruss_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -266,8 +264,8 @@ program main real(c_double), parameter :: nlscoef = 1.d-2 ! non-linear solver coefficient integer(c_int), parameter :: order = 3 ! method order - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunls ! sundials linear solver type(c_ptr) :: arkode_mem ! ARKODE memory real(c_double), pointer, dimension(neq) :: yvec(:) ! underlying vector @@ -279,17 +277,17 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 10.0d0 - tcur = tstart - tout = tstart - dtout = 1.0d0 - nout = ceiling(tend/dtout) + tend = 10.0d0 + tcur = tstart + tout = tstart + dtout = 1.0d0 + nout = ceiling(tend/dtout) ! create SUNDIALS N_Vector sunvec_y => FN_VNew_Serial(neq, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if yvec => FN_VGetArrayPointer(sunvec_y) @@ -298,31 +296,31 @@ program main ! create ARKStep memory arkode_mem = FARKStepCreate(c_funloc(ExpRhsFn), c_funloc(ImpRhsFn), tstart, sunvec_y, sunctx) - if (.not. c_associated(arkode_mem)) print *,'ERROR: arkode_mem = NULL' + if (.not. c_associated(arkode_mem)) print *, 'ERROR: arkode_mem = NULL' ! Tell ARKODE to use a dense linear solver with user-supplied Jacobian function. sunmat_A => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if sunls => FSUNLinSol_Dense(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - stop 1 + print *, 'ERROR: sunls = NULL' + stop 1 end if ierr = FARKodeSetLinearSolver(arkode_mem, sunls, sunmat_A) if (ierr /= 0) then - print *, 'Error in FARKodeSetLinearSolver' - stop 1 + print *, 'Error in FARKodeSetLinearSolver' + stop 1 end if ierr = FARKodeSetJacFn(arkode_mem, c_funloc(Jac)) if (ierr /= 0) then - print *, 'Error in FARKodeSetJacFn' - stop 1 + print *, 'Error in FARKodeSetJacFn' + stop 1 end if ! set relative and absolute tolerances @@ -331,21 +329,21 @@ program main ierr = FARKodeSStolerances(arkode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! Set additional method parameters ierr = FARKodeSetOrder(arkode_mem, order) if (ierr /= 0) then - print *, 'Error in FARKodeSetOrder' - stop 1 + print *, 'Error in FARKodeSetOrder' + stop 1 end if ierr = FARKodeSetNonlinConvCoef(arkode_mem, nlscoef) if (ierr /= 0) then - print *, 'Error in FARKodeSetNonlinConvCoef' - stop 1 + print *, 'Error in FARKodeSetNonlinConvCoef' + stop 1 end if imethod = 0 @@ -354,16 +352,16 @@ program main adapt_params = 0.d0 ierr = FARKStepSetAdaptivityMethod(arkode_mem, imethod, idefault, pq, adapt_params) if (ierr /= 0) then - print *, 'Error in FARKStepSetAdaptivityMethod, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKStepSetAdaptivityMethod, ierr = ', ierr, '; halting' + stop 1 end if ! Open output stream for results, output comment line - open(100, file='solution.txt') - write(100,*) '# t u v w' + open (100, file='solution.txt') + write (100, *) '# t u v w' ! output initial condition to disk - write(100,'(3x,4(es23.16,1x))') tstart, yvec + write (100, '(3x,4(es23.16,1x))') tstart, yvec ! Start time stepping print *, ' ' @@ -372,23 +370,23 @@ program main print *, ' t u v w ' print *, ' ---------------------------------------------------' print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - do outstep = 1,nout + do outstep = 1, nout - ! call ARKodeEvolve - tout = min(tout + dtout, tend) - ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) - if (ierr /= 0) then - print *, 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' - stop 1 - endif + ! call ARKodeEvolve + tout = min(tout + dtout, tend) + ierr = FARKodeEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL) + if (ierr /= 0) then + print *, 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - write(100,'(3x,4(es23.16,1x))') tcur, yvec(1), yvec(2), yvec(3) + ! output current solution + print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) + write (100, '(3x,4(es23.16,1x))') tcur, yvec(1), yvec(2), yvec(3) - enddo + end do print *, ' ----------------------------------------------------' - close(100) + close (100) ! diagnostics output call ARKStepStats(arkode_mem) @@ -403,7 +401,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! ARKStepStats ! @@ -443,91 +440,91 @@ subroutine ARKStepStats(arkode_mem) ierr = FARKodeGetNumSteps(arkode_mem, nsteps) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumSteps, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumStepAttempts, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumStepAttempts, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (ierr /= 0) then - print *, 'Error in FARKStepGetNumRhsEvals, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKStepGetNumRhsEvals, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetActualInitStep(arkode_mem, hinused) if (ierr /= 0) then - print *, 'Error in FARKodeGetActualInitStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetActualInitStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetLastStep(arkode_mem, hlast) if (ierr /= 0) then - print *, 'Error in FARKodeGetLastStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetLastStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetCurrentStep(arkode_mem, hcur) if (ierr /= 0) then - print *, 'Error in FARKodeGetCurrentStep, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentStep, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetCurrentTime(arkode_mem, tcur) if (ierr /= 0) then - print *, 'Error in FARKodeGetCurrentTime, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentTime, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumLinSolvSetups(arkode_mem, nlinsetups) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumErrTestFails(arkode_mem, netfails) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumErrTestFails, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumErrTestFails, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvIters(arkode_mem, nniters) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvConvFails(arkode_mem, nncfails) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumJacEvals(arkode_mem, njacevals) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumJacEvals, retval = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumJacEvals, retval = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total internal steps attempts =',nst_a - print '(4x,A,i9)' ,'Total rhs exp function calls =',nfe - print '(4x,A,i9)' ,'Total rhs imp function calls =',nfi - print '(4x,A,i9)' ,'Total jac function calls =',njacevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total internal steps attempts =', nst_a + print '(4x,A,i9)', 'Total rhs exp function calls =', nfe + print '(4x,A,i9)', 'Total rhs imp function calls =', nfi + print '(4x,A,i9)', 'Total jac function calls =', njacevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/arkode/F2003_serial/ark_diurnal_kry_bp_f2003.f90 b/examples/arkode/F2003_serial/ark_diurnal_kry_bp_f2003.f90 index ab8fa486a8..6cdc9bad24 100644 --- a/examples/arkode/F2003_serial/ark_diurnal_kry_bp_f2003.f90 +++ b/examples/arkode/F2003_serial/ark_diurnal_kry_bp_f2003.f90 @@ -53,7 +53,7 @@ module DiurnalKryBP_mod implicit none ! setup and number of equations - integer(c_int), parameter :: mx = 10, my = 10 + integer(c_int), parameter :: mx = 10, my = 10 integer(c_int64_t), parameter :: mm = mx*my integer(c_int64_t), parameter :: neq = 2*mm @@ -107,7 +107,7 @@ module DiurnalKryBP_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function ImpRhsFn(tn, sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C,name='ImpRhsFn') + result(ierr) bind(C, name='ImpRhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -119,7 +119,7 @@ integer(c_int) function ImpRhsFn(tn, sunvec_u, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local data integer(c_int) :: jleft, jright, jdn, jup @@ -129,69 +129,69 @@ integer(c_int) function ImpRhsFn(tn, sunvec_u, sunvec_f, user_data) & real(c_double) :: vertd1, vertd2, ydn, yup ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(2,mx,my) :: uvecI(:,:,:) - real(c_double), pointer, dimension(2,mx,my) :: fvecI(:,:,:) + real(c_double), pointer, dimension(2, mx, my) :: uvecI(:, :, :) + real(c_double), pointer, dimension(2, mx, my) :: fvecI(:, :, :) !======= Internals ============ ! get data arrays from SUNDIALS vectors - uvecI(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) - fvecI(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_f) + uvecI(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) + fvecI(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_f) ! Set diurnal rate coefficients. - s = sin(om * tn) + s = sin(om*tn) if (s > 0.0d0) then - q3 = exp(-a3 / s) - q4 = exp(-a4 / s) + q3 = exp(-a3/s) + q4 = exp(-a4/s) else - q3 = 0.0d0 - q4 = 0.0d0 + q3 = 0.0d0 + q4 = 0.0d0 end if ! Loop over all grid points. do jy = 1, my - ydn = 30.0d0 + (jy - 1.5d0) * dy - yup = ydn + dy - cydn = vdco * exp(0.2d0 * ydn) - cyup = vdco * exp(0.2d0 * yup) - jdn = jy-1 - if (jy == 1) jdn = my - jup = jy+1 - if (jy == my) jup = 1 - do jx = 1, mx - c1 = uvecI(1,jx,jy) - c2 = uvecI(2,jx,jy) - ! Set kinetic rate terms. - qq1 = q1 * c1 * c3 - qq2 = q2 * c1 * c2 - qq3 = q3 * c3 - qq4 = q4 * c2 - rkin1 = -qq1 - qq2 + 2.0d0 * qq3 + qq4 - rkin2 = qq1 - qq2 - qq4 - ! Set vertical diffusion terms. - c1dn = uvecI(1,jx,jdn) - c2dn = uvecI(2,jx,jdn) - c1up = uvecI(1,jx,jup) - c2up = uvecI(2,jx,jup) - vertd1 = cyup * (c1up - c1) - cydn * (c1 - c1dn) - vertd2 = cyup * (c2up - c2) - cydn * (c2 - c2dn) - ! Set horizontal diffusion and advection terms. - jleft = jx-1 - if (jx == 1) jleft = mx - jright = jx+1 - if (jx == mx) jright = 1 - c1lt = uvecI(1,jleft,jy) - c2lt = uvecI(2,jleft,jy) - c1rt = uvecI(1,jright,jy) - c2rt = uvecI(2,jright,jy) - hord1 = hdco * (c1rt - 2.0d0 * c1 + c1lt) - hord2 = hdco * (c2rt - 2.0d0 * c2 + c2lt) - horad1 = haco * (c1rt - c1lt) - horad2 = haco * (c2rt - c2lt) - ! load all terms into fvecI. - fvecI(1,jx,jy) = vertd1 + hord1 + horad1 + rkin1 - fvecI(2,jx,jy) = vertd2 + hord2 + horad2 + rkin2 - end do + ydn = 30.0d0 + (jy - 1.5d0)*dy + yup = ydn + dy + cydn = vdco*exp(0.2d0*ydn) + cyup = vdco*exp(0.2d0*yup) + jdn = jy - 1 + if (jy == 1) jdn = my + jup = jy + 1 + if (jy == my) jup = 1 + do jx = 1, mx + c1 = uvecI(1, jx, jy) + c2 = uvecI(2, jx, jy) + ! Set kinetic rate terms. + qq1 = q1*c1*c3 + qq2 = q2*c1*c2 + qq3 = q3*c3 + qq4 = q4*c2 + rkin1 = -qq1 - qq2 + 2.0d0*qq3 + qq4 + rkin2 = qq1 - qq2 - qq4 + ! Set vertical diffusion terms. + c1dn = uvecI(1, jx, jdn) + c2dn = uvecI(2, jx, jdn) + c1up = uvecI(1, jx, jup) + c2up = uvecI(2, jx, jup) + vertd1 = cyup*(c1up - c1) - cydn*(c1 - c1dn) + vertd2 = cyup*(c2up - c2) - cydn*(c2 - c2dn) + ! Set horizontal diffusion and advection terms. + jleft = jx - 1 + if (jx == 1) jleft = mx + jright = jx + 1 + if (jx == mx) jright = 1 + c1lt = uvecI(1, jleft, jy) + c2lt = uvecI(2, jleft, jy) + c1rt = uvecI(1, jright, jy) + c2rt = uvecI(2, jright, jy) + hord1 = hdco*(c1rt - 2.0d0*c1 + c1lt) + hord2 = hdco*(c2rt - 2.0d0*c2 + c2lt) + horad1 = haco*(c1rt - c1lt) + horad2 = haco*(c2rt - c2lt) + ! load all terms into fvecI. + fvecI(1, jx, jy) = vertd1 + hord1 + horad1 + rkin1 + fvecI(2, jx, jy) = vertd2 + hord2 + horad2 + rkin2 + end do end do ! return success @@ -204,7 +204,6 @@ end function ImpRhsFn end module DiurnalKryBP_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -233,12 +232,12 @@ program main integer(c_int64_t) :: mu, ml ! band preconditioner constants real(c_double) :: x, y ! initialization index variables - type(N_Vector), pointer :: sunvec_u ! sundials vector - type(N_Vector), pointer :: sunvec_f ! sundials vector + type(N_Vector), pointer :: sunvec_u ! sundials vector + type(N_Vector), pointer :: sunvec_f ! sundials vector type(SUNLinearSolver), pointer :: sunls ! sundials linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) type(c_ptr) :: arkode_mem ! ARKODE memory - real(c_double), pointer, dimension(2,mx,my) :: uvec(:,:,:) ! underlying vector + real(c_double), pointer, dimension(2, mx, my) :: uvec(:, :, :) ! underlying vector ! output statistic variables integer(c_long) :: lnst(1), lnst_att(1) @@ -251,81 +250,80 @@ program main ! initialize ODE tstart = 0.0d0 - tcur = tstart + tcur = tstart ! create SUNDIALS N_Vectors sunvec_u => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - uvec(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) + uvec(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) sunvec_f => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_f)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - ! initialize and fill initial condition vector - do jy = 1,my - y = 30.0d0 + (jy - 1.0d0) * dy - cy = (0.1d0 * (y - 40.0d0))**2 - cy = 1.0d0 - cy + 0.5d0 * cy**2 - do jx = 1,mx - x = (jx - 1.0d0) * dx - cx = (0.1d0 * (x - 10.0d0))**2 - cx = 1.0d0 - cx + 0.5d0 * cx**2 - uvec(1,jx,jy) = 1.0d6 * cx * cy - uvec(2,jx,jy) = 1.0d12 * cx * cy - end do + do jy = 1, my + y = 30.0d0 + (jy - 1.0d0)*dy + cy = (0.1d0*(y - 40.0d0))**2 + cy = 1.0d0 - cy + 0.5d0*cy**2 + do jx = 1, mx + x = (jx - 1.0d0)*dx + cx = (0.1d0*(x - 10.0d0))**2 + cx = 1.0d0 - cx + 0.5d0*cx**2 + uvec(1, jx, jy) = 1.0d6*cx*cy + uvec(2, jx, jy) = 1.0d12*cx*cy + end do end do ! create ARKStep memory arkode_mem = FARKStepCreate(c_null_funptr, c_funloc(ImpRhsFn), tstart, sunvec_u, ctx) - if (.not. c_associated(arkode_mem)) print *,'ERROR: arkode_mem = NULL' + if (.not. c_associated(arkode_mem)) print *, 'ERROR: arkode_mem = NULL' ! Tell ARKODE to use a SPGMR linear solver. sunls => FSUNLinSol_SPGMR(sunvec_u, Jpretype, maxL, ctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - stop 1 + print *, 'ERROR: sunls = NULL' + stop 1 end if ! Attach the linear solver (with NULL SUNMatrix object) sunmat_A => null() ierr = FARKodeSetLinearSolver(arkode_mem, sunls, sunmat_A) if (ierr /= 0) then - print *, 'Error in FARKodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ierr = FSUNLinSol_SPGMRSetGSType(sunls, iGStype) if (ierr /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetGSType, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetGSType, ierr = ', ierr, '; halting' + stop 1 end if mu = 2 ml = 2 ierr = FARKBandPrecInit(arkode_mem, neq, mu, ml) if (ierr /= 0) then - print *, 'Error in FARKBandPrecInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKBandPrecInit, ierr = ', ierr, '; halting' + stop 1 end if ! Set additional method parameters ierr = FARKodeSStolerances(arkode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeSetMaxNumSteps(arkode_mem, mxsteps) if (ierr /= 0) then - print *, 'Error in FARKodeSetMaxNumSteps' - stop 1 + print *, 'Error in FARKodeSetMaxNumSteps' + stop 1 end if ! Start time stepping @@ -336,40 +334,40 @@ program main print *, ' t c2 (bottom left middle top right) | lnst lnst_att lh' print *, ' ----------------------------------------------------------------------------------------' tout = twohr - do outstep = 1,12 - - ! call ARKodeEvolve - ierr = FARKodeEvolve(arkode_mem, tout, sunvec_u, tcur, ARK_NORMAL) - if (ierr /= 0) then - print *, 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' - stop 1 - end if - - ! get some solver statistics - ierr = FARKodeGetNumSteps(arkode_mem, lnst) - if (ierr /= 0) then - print *, 'Error in FARKodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 - end if - - ierr = FARKodeGetNumStepAttempts(arkode_mem, lnst_att) - if (ierr /= 0) then - print *, 'Error in FARKodeGetNumStepAttempts, ierr = ', ierr, '; halting' - stop 1 - end if - - ierr = FARKodeGetCurrentStep(arkode_mem, lh) - if (ierr /= 0) then - print *, 'Error in FARKodeGetCurrentStep, ierr = ', ierr, '; halting' - stop 1 - end if - - ! print current solution and output statistics - print '(2x,4(es14.6,2x),i5,i5,es14.6)', tcur, uvec(1,1,1), uvec(1,5,5), uvec(1,10,10), lnst, lnst_att, lh - print '(18x,3(es14.6,2x))', uvec(2,1,1), uvec(2,5,5), uvec(2,10,10) - - ! update tout - tout = tout + twohr + do outstep = 1, 12 + + ! call ARKodeEvolve + ierr = FARKodeEvolve(arkode_mem, tout, sunvec_u, tcur, ARK_NORMAL) + if (ierr /= 0) then + print *, 'Error in FARKodeEvolve, ierr = ', ierr, '; halting' + stop 1 + end if + + ! get some solver statistics + ierr = FARKodeGetNumSteps(arkode_mem, lnst) + if (ierr /= 0) then + print *, 'Error in FARKodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 + end if + + ierr = FARKodeGetNumStepAttempts(arkode_mem, lnst_att) + if (ierr /= 0) then + print *, 'Error in FARKodeGetNumStepAttempts, ierr = ', ierr, '; halting' + stop 1 + end if + + ierr = FARKodeGetCurrentStep(arkode_mem, lh) + if (ierr /= 0) then + print *, 'Error in FARKodeGetCurrentStep, ierr = ', ierr, '; halting' + stop 1 + end if + + ! print current solution and output statistics + print '(2x,4(es14.6,2x),i5,i5,es14.6)', tcur, uvec(1, 1, 1), uvec(1, 5, 5), uvec(1, 10, 10), lnst, lnst_att, lh + print '(18x,3(es14.6,2x))', uvec(2, 1, 1), uvec(2, 5, 5), uvec(2, 10, 10) + + ! update tout + tout = tout + twohr end do print *, ' ----------------------------------------------------------------------------------------' @@ -387,7 +385,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! ARKStepStats ! @@ -431,108 +428,108 @@ subroutine ARKStepStats(arkode_mem) ierr = FARKodeGetNumSteps(arkode_mem, nsteps) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumStepAttempts, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumStepAttempts, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (ierr /= 0) then - print *, 'Error in FARKStepGetNumRhsEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKStepGetNumRhsEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumErrTestFails(arkode_mem, netfails) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumErrTestFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumErrTestFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumPrecEvals(arkode_mem, npe) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumPrecEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumPrecEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumPrecSolves(arkode_mem, nps) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumPrecSolves, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumPrecSolves, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvIters(arkode_mem, nniters) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumLinIters(arkode_mem, nliters) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumLinIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumLinIters, ierr = ', ierr, '; halting' + stop 1 end if avdim = dble(nliters)/dble(nniters) ierr = FARKodeGetNumLinConvFails(arkode_mem, ncfl) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumLinConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumLinConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetNumNonlinSolvConvFails(arkode_mem, ncf) if (ierr /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetWorkSpace(arkode_mem, lenrw, leniw) if (ierr /= 0) then - print *, 'Error in FARKodeGetWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKodeGetLinWorkSpace(arkode_mem, lenrwls, leniwls) if (ierr /= 0) then - print *, 'Error in FARKodeGetLinWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKodeGetLinWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKBandPrecGetWorkSpace(arkode_mem, lenrwbp, leniwbp) if (ierr /= 0) then - print *, 'Error in FARKBandPrecGetWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKBandPrecGetWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ierr = FARKBandPrecGetNumRhsEvals(arkode_mem, nfebp) if (ierr /= 0) then - print *, 'Error in FARKBandPrecGetNumRhsEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FARKBandPrecGetNumRhsEvals, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total internal steps attempts =',nst_a - print '(4x,A,i9)' ,'Total rhs exp function call =',nfe - print '(4x,A,i9)' ,'Total rhs imp function call =',nfi - print '(4x,A,i9)' ,'Total num preconditioner evals =',npe - print '(4x,A,i9)' ,'Total num preconditioner solves =',nps - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num linear solver iters =',nliters - print '(4x,A,es14.6)' ,'Avg Krylov subspace dim =',avdim - print '(4x,A,i9)' ,'Num nonlinear solver fails =',ncf - print '(4x,A,i9)' ,'Num linear solver fails =',ncfl - print '(4x,A,2(i9,3x))' ,'main solver real/int workspace sizes =',lenrw,leniw - print '(4x,A,2(i9,3x))' ,'linear solver real/int workspace sizes =',lenrwls,leniwls - print '(4x,A,2(i9,3x))' ,'ARKBandPre real/int workspace sizes =',lenrwbp,leniwbp - print '(4x,A,i9)' ,'ARKBandPre number of f evaluations =',nfebp + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total internal steps attempts =', nst_a + print '(4x,A,i9)', 'Total rhs exp function call =', nfe + print '(4x,A,i9)', 'Total rhs imp function call =', nfi + print '(4x,A,i9)', 'Total num preconditioner evals =', npe + print '(4x,A,i9)', 'Total num preconditioner solves =', nps + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num linear solver iters =', nliters + print '(4x,A,es14.6)', 'Avg Krylov subspace dim =', avdim + print '(4x,A,i9)', 'Num nonlinear solver fails =', ncf + print '(4x,A,i9)', 'Num linear solver fails =', ncfl + print '(4x,A,2(i9,3x))', 'main solver real/int workspace sizes =', lenrw, leniw + print '(4x,A,2(i9,3x))', 'linear solver real/int workspace sizes =', lenrwls, leniwls + print '(4x,A,2(i9,3x))', 'ARKBandPre real/int workspace sizes =', lenrwbp, leniwbp + print '(4x,A,i9)', 'ARKBandPre number of f evaluations =', nfebp print *, ' ' return diff --git a/examples/arkode/F2003_serial/ark_kpr_mri_f2003.f90 b/examples/arkode/F2003_serial/ark_kpr_mri_f2003.f90 index cb0aa027d0..2b5cc5747e 100644 --- a/examples/arkode/F2003_serial/ark_kpr_mri_f2003.f90 +++ b/examples/arkode/F2003_serial/ark_kpr_mri_f2003.f90 @@ -86,23 +86,23 @@ module kpr_mod ! Constants real(c_double) :: ZERO = 0.0d0 - real(c_double) :: ONE = 1.0d0 - real(c_double) :: TWO = 2.0d0 + real(c_double) :: ONE = 1.0d0 + real(c_double) :: TWO = 2.0d0 ! general problem parameters - real(c_double), parameter :: T0 = 0.0d0 ! initial time - real(c_double), parameter :: Tf = 5.0d0 ! final time - real(c_double), parameter :: dTout = 0.1d0 ! time between outputs - integer(c_int64_t), parameter :: NEQ = 2 ! number of dependent vars. - integer(c_int), parameter :: Nt = ceiling(Tf/dTout) ! number of output times + real(c_double), parameter :: T0 = 0.0d0 ! initial time + real(c_double), parameter :: Tf = 5.0d0 ! final time + real(c_double), parameter :: dTout = 0.1d0 ! time between outputs + integer(c_int64_t), parameter :: NEQ = 2 ! number of dependent vars. + integer(c_int), parameter :: Nt = ceiling(Tf/dTout) ! number of output times ! parameters that can be modified via CLI args or are derived - real(c_double) :: hs = 0.01d0 ! slow step size - real(c_double) :: e = 0.5d0 ! fast/slow coupling strength - real(c_double) :: G = -100.0d0 ! stiffness at slow time scale - real(c_double) :: w = 100.0d0 ! time-scale separation factor - real(c_double) :: reltol = 0.01d0 ! integrator tolerances - real(c_double) :: abstol = 1e-11 + real(c_double) :: hs = 0.01d0 ! slow step size + real(c_double) :: e = 0.5d0 ! fast/slow coupling strength + real(c_double) :: G = -100.0d0 ! stiffness at slow time scale + real(c_double) :: w = 100.0d0 ! time-scale separation factor + real(c_double) :: reltol = 0.01d0 ! integrator tolerances + real(c_double) :: abstol = 1e-11 contains @@ -121,7 +121,7 @@ integer(c_int) function ff(t, yvec, ydotvec, user_data) & real(c_double), value :: t type(N_Vector) :: yvec type(N_Vector) :: ydotvec - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data real(c_double) :: u, v real(c_double) :: tmp1, tmp2 @@ -139,8 +139,8 @@ integer(c_int) function ff(t, yvec, ydotvec, user_data) & ! fill in the RHS function: ! [0 0]*[(-1+u^2-r(t))/(2*u)] + [ 0 ] ! [e -1] [(-2+v^2-s(t))/(2*v)] [sdot(t)/(2*vtrue(t))] - tmp1 = (-ONE+u*u-r(t))/(TWO*u) - tmp2 = (-TWO+v*v-s(t))/(TWO*v) + tmp1 = (-ONE + u*u - r(t))/(TWO*u) + tmp2 = (-TWO + v*v - s(t))/(TWO*v) ydotarr(1) = ZERO ydotarr(2) = e*tmp1 - tmp2 + sdot(t)/(TWO*vtrue(t)) @@ -162,7 +162,7 @@ integer(c_int) function fs(t, yvec, ydotvec, user_data) & real(c_double), value :: t type(N_Vector) :: yvec type(N_Vector) :: ydotvec - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data real(c_double) :: u, v real(c_double) :: tmp1, tmp2 @@ -180,8 +180,8 @@ integer(c_int) function fs(t, yvec, ydotvec, user_data) & ! fill in the RHS function: ! [G e]*[(-1+u^2-r(t))/(2*u))] + [rdot(t)/(2*u)] ! [0 0] [(-2+v^2-s(t))/(2*v)] [ 0 ] - tmp1 = (-ONE+u*u-r(t))/(TWO*u) - tmp2 = (-TWO+v*v-s(t))/(TWO*v) + tmp1 = (-ONE + u*u - r(t))/(TWO*u) + tmp2 = (-TWO + v*v - s(t))/(TWO*v) ydotarr(1) = G*tmp1 + e*tmp2 + rdot(t)/(TWO*u) ydotarr(2) = ZERO @@ -203,7 +203,7 @@ integer(c_int) function fse(t, yvec, ydotvec, user_data) & real(c_double), value :: t type(N_Vector) :: yvec type(N_Vector) :: ydotvec - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data real(c_double) :: u, v real(c_double), pointer, dimension(NEQ) :: yarr(:) @@ -241,7 +241,7 @@ integer(c_int) function fsi(t, yvec, ydotvec, user_data) & real(c_double), value :: t type(N_Vector) :: yvec type(N_Vector) :: ydotvec - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data real(c_double) :: u, v real(c_double) :: tmp1, tmp2 @@ -259,8 +259,8 @@ integer(c_int) function fsi(t, yvec, ydotvec, user_data) & ! fill in the slow implicit RHS function: ! [G e]*[(-1+u^2-r(t))/(2*u))] ! [0 0] [(-2+v^2-s(t))/(2*v)] - tmp1 = (-ONE+u*u-r(t))/(TWO*u) - tmp2 = (-TWO+v*v-s(t))/(TWO*v) + tmp1 = (-ONE + u*u - r(t))/(TWO*u) + tmp2 = (-TWO + v*v - s(t))/(TWO*v) ydotarr(1) = G*tmp1 + e*tmp2 ydotarr(2) = ZERO @@ -281,7 +281,7 @@ integer(c_int) function fn(t, yvec, ydotvec, user_data) & real(c_double), value :: t type(N_Vector) :: yvec type(N_Vector) :: ydotvec - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data real(c_double) :: u, v real(c_double) :: tmp1, tmp2 @@ -299,8 +299,8 @@ integer(c_int) function fn(t, yvec, ydotvec, user_data) & ! fill in the RHS function: ! [G e]*[(-1+u^2-r(t))/(2*u))] + [rdot(t)/(2*u)] ! [e -1] [(-2+v^2-s(t))/(2*v)] [sdot(t)/(2*vtrue(t))] - tmp1 = (-ONE+u*u-r(t))/(TWO*u) - tmp2 = (-TWO+v*v-s(t))/(TWO*v) + tmp1 = (-ONE + u*u - r(t))/(TWO*u) + tmp2 = (-TWO + v*v - s(t))/(TWO*v) ydotarr(1) = G*tmp1 + e*tmp2 + rdot(t)/(TWO*u) ydotarr(2) = e*tmp1 - tmp2 + sdot(t)/(TWO*vtrue(t)) @@ -321,7 +321,7 @@ integer(c_int) function f0(t, yvec, ydotvec, user_data) & real(c_double), value :: t type(N_Vector) :: yvec type(N_Vector) :: ydotvec - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data call FN_VConst(ZERO, ydotvec) @@ -346,18 +346,18 @@ integer(c_int) function Js(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & type(N_Vector) :: y type(N_Vector) :: fy type(SUNMatrix) :: J - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data type(N_Vector) :: tmp1, tmp2, tmp3 real(c_double) :: u, v real(c_double), pointer, dimension(NEQ) :: yarr(:) - real(c_double), pointer, dimension(NEQ,NEQ) :: Jarr(:,:) + real(c_double), pointer, dimension(NEQ, NEQ) :: Jarr(:, :) ! get N_Vector data arrays yarr => FN_VGetArrayPointer(y) ! get Jacobian data array - Jarr(1:NEQ,1:NEQ) => FSUNDenseMatrix_Data(J) + Jarr(1:NEQ, 1:NEQ) => FSUNDenseMatrix_Data(J) ! extract variables u = yarr(1) @@ -366,10 +366,10 @@ integer(c_int) function Js(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & ! fill in the Jacobian: ! [G/2 + (w*(1+r(t))-rdot(t))/(2*u^2) e/2 + e*(2+s(t))/(2*v^2)] ! [ 0 0 ] - Jarr(1,1) = G/TWO + (G*(ONE+r(t))-rdot(t))/(2*u*u) - Jarr(2,1) = ZERO - Jarr(1,2) = e/TWO + e*(TWO+s(t))/(TWO*v*v) - Jarr(2,2) = ZERO + Jarr(1, 1) = G/TWO + (G*(ONE + r(t)) - rdot(t))/(2*u*u) + Jarr(2, 1) = ZERO + Jarr(1, 2) = e/TWO + e*(TWO + s(t))/(TWO*v*v) + Jarr(2, 2) = ZERO ! return success ierr = 0 @@ -388,18 +388,18 @@ integer(c_int) function Jsi(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & type(N_Vector) :: y type(N_Vector) :: fy type(SUNMatrix) :: J - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data type(N_Vector) :: tmp1, tmp2, tmp3 real(c_double) :: u, v real(c_double), pointer, dimension(NEQ) :: yarr(:) - real(c_double), pointer, dimension(NEQ,NEQ) :: Jarr(:,:) + real(c_double), pointer, dimension(NEQ, NEQ) :: Jarr(:, :) ! get N_Vector data array yarr => FN_VGetArrayPointer(y) ! get Jacobian data array - Jarr(1:NEQ,1:NEQ) => FSUNDenseMatrix_Data(J) + Jarr(1:NEQ, 1:NEQ) => FSUNDenseMatrix_Data(J) ! extract variables u = yarr(1) @@ -408,10 +408,10 @@ integer(c_int) function Jsi(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & ! fill in the Jacobian: ! [G/2 + (G*(1+r(t)))/(2*u^2) e/2+e*(2+s(t))/(2*v^2)] ! [ 0 0 ] - Jarr(1,1) = G/TWO + (G*(ONE+r(t)))/(2*u*u) - Jarr(2,1) = ZERO - Jarr(1,2) = e/TWO + e*(TWO+s(t))/(TWO*v*v) - Jarr(2,2) = ZERO + Jarr(1, 1) = G/TWO + (G*(ONE + r(t)))/(2*u*u) + Jarr(2, 1) = ZERO + Jarr(1, 2) = e/TWO + e*(TWO + s(t))/(TWO*v*v) + Jarr(2, 2) = ZERO ! return success ierr = 0 @@ -430,18 +430,18 @@ integer(c_int) function Jn(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & type(N_Vector) :: y type(N_Vector) :: fy type(SUNMatrix) :: J - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data type(N_Vector) :: tmp1, tmp2, tmp3 real(c_double) :: u, v real(c_double), pointer, dimension(NEQ) :: yarr(:) - real(c_double), pointer, dimension(NEQ,NEQ) :: Jarr(:,:) + real(c_double), pointer, dimension(NEQ, NEQ) :: Jarr(:, :) ! get N_Vector data array yarr => FN_VGetArrayPointer(y) ! get Jacobian data array - Jarr(1:NEQ,1:NEQ) => FSUNDenseMatrix_Data(J) + Jarr(1:NEQ, 1:NEQ) => FSUNDenseMatrix_Data(J) ! extract variables u = yarr(1) @@ -450,10 +450,10 @@ integer(c_int) function Jn(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & ! fill in the Jacobian: ! [G/2 + (G*(1+r(t))-rdot(t))/(2*u^2) e/2 + e*(2+s(t))/(2*v^2)] ! [e/2 + e*(1+r(t))/(2*u^2) -1/2 - (2+s(t))/(2*v^2)] - Jarr(1,1) = G/TWO + (G*(1+r(t))-rdot(t))/(TWO*u*u) - Jarr(2,1) = e/TWO + e*(ONE+r(t))/(TWO*u*u) - Jarr(1,2) = e/TWO + e*(TWO+s(t))/(TWO*v*v) - Jarr(2,2) = -ONE/TWO - (TWO+s(t))/(TWO*v*v) + Jarr(1, 1) = G/TWO + (G*(1 + r(t)) - rdot(t))/(TWO*u*u) + Jarr(2, 1) = e/TWO + e*(ONE + r(t))/(TWO*u*u) + Jarr(1, 2) = e/TWO + e*(TWO + s(t))/(TWO*v*v) + Jarr(2, 2) = -ONE/TWO - (TWO + s(t))/(TWO*v*v) ! return success ierr = 0 @@ -526,7 +526,7 @@ real(c_double) function utrue(t) & real(c_double) :: t - result = sqrt(ONE+r(t)) + result = sqrt(ONE + r(t)) return end function utrue @@ -540,7 +540,7 @@ real(c_double) function vtrue(t) & real(c_double) :: t - result = sqrt(TWO+s(t)) + result = sqrt(TWO + s(t)) return end function vtrue @@ -571,7 +571,6 @@ end function Ytrue end module kpr_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -580,7 +579,6 @@ program main use kpr_mod implicit none - ! general problem variables type(c_ptr) sunctx ! SUNDIALS simulation context integer(c_int) :: retval ! reusable error-checking flag @@ -600,8 +598,8 @@ program main logical :: imex_slow = .FALSE. real(c_double) :: hf, gamma, beta, t, tret(1), tout real(c_double) :: uerr, verr, uerrtot, verrtot, errtot - real(c_double), allocatable :: Af(:,:), bf(:), cf(:), df(:) ! Arrays for fast Butcher table, NOTE: must be in row-major order - real(c_double), allocatable :: As(:,:), bs(:), cs(:), ds(:) ! Arrays for slow Butcher table, NOTE: must be in row-major order + real(c_double), allocatable :: Af(:, :), bf(:), cf(:), df(:) ! Arrays for fast Butcher table, NOTE: must be in row-major order + real(c_double), allocatable :: As(:, :), bs(:), cs(:), ds(:) ! Arrays for slow Butcher table, NOTE: must be in row-major order integer(c_int) :: iout, argc, argi integer(c_long) :: nsts(1), nstf(1), nfse(1), nfsi(1), nff(1) integer(c_long) :: nnif(1), nncf(1), njef(1), nnis(1), nncs(1), njes(1), tmp(1) @@ -622,18 +620,18 @@ program main LSs => null() argc = command_argument_count() - allocate(argv(argc)) ! I've omitted checking the return status of the allocation + allocate (argv(argc)) ! I've omitted checking the return status of the allocation do argi = 1, argc call get_command_argument(argi, argv(argi)) end do ! Retrieve the command-line options: solve_type h G w e */ - if (argc > 0) read(argv(1), *) solve_type - if (argc > 1) read(argv(2), *) hs - if (argc > 2) read(argv(3), *) G - if (argc > 3) read(argv(4), *) w - if (argc > 4) read(argv(5), *) e + if (argc > 0) read (argv(1), *) solve_type + if (argc > 1) read (argv(2), *) hs + if (argc > 2) read (argv(3), *) G + if (argc > 3) read (argv(4), *) w + if (argc > 4) read (argv(5), *) e ! Check arguments for validity ! 0 <= solve_type <= 9 @@ -643,11 +641,11 @@ program main ! w >= 1.0 if ((solve_type < 0) .or. (solve_type > 9)) then print *, "ERROR: solve_type be an integer in [0,9]" - stop -1 + stop - 1 end if if (G >= ZERO) then print *, "ERROR: G must be a negative real number" - stop -1 + stop - 1 end if implicit_slow = .false. if ((solve_type == 4) .or. (solve_type == 7)) then @@ -659,15 +657,15 @@ program main end if if (hs <= ZERO) then print *, "ERROR: hs must be in positive" - stop -1 + stop - 1 end if if ((hs > ONE/abs(G)) .and. (.not. implicit_slow)) then print *, "ERROR: hs must be in (0, 1/|G|)" - stop -1 + stop - 1 end if if (w < ONE) then print *, "ERROR: w must be >= 1.0" - stop -1 + stop - 1 end if hf = hs/w @@ -681,41 +679,41 @@ program main print '(A,E12.4,A)', " e = ", e select case (solve_type) - case (0) - print *, " solver: exp-3/exp-3 (standard MIS)" - case (1) - print *, " solver: none/exp-3 (no slow, explicit fast)" - case (2) - reltol = max(hs*hs*hs, real(1e-10,8)) - abstol = 1e-11 - print *, " solver: none/dirk-3 (no slow, dirk fast)" - print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol - case (3) - print *, " solver: exp-3/none (explicit slow, no fast)" - case (4) - reltol = max(hs*hs, real(1e-10,8)) - abstol = 1e-11 - print *, " solver: dirk-2/none (dirk slow, no fast)" - print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol - case (5) - print *, " solver: exp-4/exp-4 (MRI-GARK-ERK45a / ERK-4-4)" - case (6) - print *, " solver: exp-4/exp-3 (MRI-GARK-ERK45a / ERK-3-3)" - case (7) - reltol = max(hs*hs*hs, real(1e-10,8)) - abstol = 1e-11 - print *, " solver: dirk-3/exp-3 (MRI-GARK-ESDIRK34a / ERK-3-3) -- solve decoupled" - print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol - case (8) - reltol = max(hs*hs*hs, real(1e-10,8)) - abstol = 1e-11 - print *, " solver: ars343/exp-3 (IMEX-MRI3b / ERK-3-3) -- solve decoupled" - print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol - case (9) - reltol = max(hs*hs*hs*hs, real(1e-14,8)) - abstol = 1e-14 - print *, " solver: imexark4/exp-4 (IMEX-MRI4 / ERK-4-4) -- solve decoupled" - print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol + case (0) + print *, " solver: exp-3/exp-3 (standard MIS)" + case (1) + print *, " solver: none/exp-3 (no slow, explicit fast)" + case (2) + reltol = max(hs*hs*hs, real(1e-10, 8)) + abstol = 1e-11 + print *, " solver: none/dirk-3 (no slow, dirk fast)" + print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol + case (3) + print *, " solver: exp-3/none (explicit slow, no fast)" + case (4) + reltol = max(hs*hs, real(1e-10, 8)) + abstol = 1e-11 + print *, " solver: dirk-2/none (dirk slow, no fast)" + print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol + case (5) + print *, " solver: exp-4/exp-4 (MRI-GARK-ERK45a / ERK-4-4)" + case (6) + print *, " solver: exp-4/exp-3 (MRI-GARK-ERK45a / ERK-3-3)" + case (7) + reltol = max(hs*hs*hs, real(1e-10, 8)) + abstol = 1e-11 + print *, " solver: dirk-3/exp-3 (MRI-GARK-ESDIRK34a / ERK-3-3) -- solve decoupled" + print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol + case (8) + reltol = max(hs*hs*hs, real(1e-10, 8)) + abstol = 1e-11 + print *, " solver: ars343/exp-3 (IMEX-MRI3b / ERK-3-3) -- solve decoupled" + print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol + case (9) + reltol = max(hs*hs*hs*hs, real(1e-14, 8)) + abstol = 1e-14 + print *, " solver: imexark4/exp-4 (IMEX-MRI4 / ERK-4-4) -- solve decoupled" + print '(A,E12.4,A,E12.4)', " reltol: ", reltol, " abstol: ", abstol end select ! Create the SUNDIALS context object for this simulation @@ -744,17 +742,17 @@ program main if (solve_type == 0 .or. solve_type == 6 .or. solve_type == 7 .or. solve_type == 8) then ! erk-3-3 fast solver inner_arkode_mem = FARKStepCreate(c_funloc(ff), c_null_funptr, T0, y, sunctx) - allocate(Af(3,3)) - allocate(bf(3)) - allocate(cf(3)) - allocate(df(3)) + allocate (Af(3, 3)) + allocate (bf(3)) + allocate (cf(3)) + allocate (df(3)) Af = 0.d0 bf = 0.d0 cf = 0.d0 df = 0.d0 - Af(1,2) = 0.5d0 - Af(1,3) = -ONE - Af(2,3) = TWO + Af(1, 2) = 0.5d0 + Af(1, 3) = -ONE + Af(2, 3) = TWO bf(1) = ONE/6.0d0 bf(2) = TWO/3.0d0 bf(3) = ONE/6.0d0 @@ -768,17 +766,17 @@ program main else if (solve_type == 1) then ! erk-3-3 fast solver (full problem) inner_arkode_mem = FARKStepCreate(c_funloc(fn), c_null_funptr, T0, y, sunctx) - allocate(Af(3,3)) - allocate(bf(3)) - allocate(cf(3)) - allocate(df(3)) + allocate (Af(3, 3)) + allocate (bf(3)) + allocate (cf(3)) + allocate (df(3)) Af = 0.d0 bf = 0.d0 cf = 0.d0 df = 0.d0 - Af(1,2) = 0.5d0 - Af(1,3) = -ONE - Af(2,3) = TWO + Af(1, 2) = 0.5d0 + Af(1, 3) = -ONE + Af(2, 3) = TWO bf(1) = ONE/6.0d0 bf(2) = TWO/3.0d0 bf(3) = ONE/6.0d0 @@ -792,17 +790,17 @@ program main else if (solve_type == 5 .or. solve_type == 9) then ! erk-4-4 fast solver inner_arkode_mem = FARKStepCreate(c_funloc(ff), c_null_funptr, T0, y, sunctx) - allocate(Af(4,4)) - allocate(bf(4)) - allocate(cf(4)) - allocate(df(4)) + allocate (Af(4, 4)) + allocate (bf(4)) + allocate (cf(4)) + allocate (df(4)) Af = 0.d0 bf = 0.d0 cf = 0.d0 df = 0.d0 - Af(1,2) = 0.5d0 - Af(2,3) = 0.5d0 - Af(3,4) = ONE + Af(1, 2) = 0.5d0 + Af(2, 3) = 0.5d0 + Af(3, 4) = ONE bf(1) = ONE/6.0d0 bf(2) = ONE/3.0d0 bf(3) = ONE/3.0d0 @@ -817,21 +815,21 @@ program main else if (solve_type == 2) then ! esdirk-3-3 fast solver (full problem) inner_arkode_mem = FARKStepCreate(c_null_funptr, c_funloc(fn), T0, y, sunctx) - beta = sqrt(3.0d0)/6.0d0 + 0.5d00 - gamma = (-ONE/8.0d0)*(sqrt(3.0d0)+ONE) - allocate(Af(3,3)) - allocate(bf(3)) - allocate(cf(3)) - allocate(df(3)) + beta = sqrt(3.0d0)/6.0d0 + 0.5d00 + gamma = (-ONE/8.0d0)*(sqrt(3.0d0) + ONE) + allocate (Af(3, 3)) + allocate (bf(3)) + allocate (cf(3)) + allocate (df(3)) Af = 0.d0 bf = 0.d0 cf = 0.d0 df = 0.d0 - Af(1,2) = 4.0d0*gamma+TWO*beta - Af(2,2) = ONE-4.0d0*gamma-TWO*beta - Af(1,3) = 0.5d0-beta-gamma - Af(2,3) = gamma - Af(3,3) = beta + Af(1, 2) = 4.0d0*gamma + TWO*beta + Af(2, 2) = ONE - 4.0d0*gamma - TWO*beta + Af(1, 3) = 0.5d0 - beta - gamma + Af(2, 3) = gamma + Af(3, 3) = beta bf(1) = ONE/6.0d0 bf(2) = ONE/6.0d0 bf(3) = TWO/3.0d0 @@ -852,17 +850,17 @@ program main else if (solve_type == 3 .or. solve_type == 4) then ! no fast dynamics ('evolve' explicitly w/ erk-3-3) inner_arkode_mem = FARKStepCreate(c_funloc(f0), c_null_funptr, T0, y, sunctx) - allocate(Af(3,3)) - allocate(bf(3)) - allocate(cf(3)) - allocate(df(3)) + allocate (Af(3, 3)) + allocate (bf(3)) + allocate (cf(3)) + allocate (df(3)) Af = 0.d0 bf = 0.d0 cf = 0.d0 df = 0.d0 - Af(1,2) = 0.5d0 - Af(1,3) = -ONE - Af(2,3) = TWO + Af(1, 2) = 0.5d0 + Af(1, 3) = -ONE + Af(2, 3) = TWO bf(1) = ONE/6.0d0 bf(2) = TWO/3.0d0 bf(3) = ONE/6.0d0 @@ -926,15 +924,15 @@ program main print *, 'ERROR: arkode_mem = NULL' stop 1 end if - allocate(As(2,2)) - allocate(bs(2)) - allocate(cs(2)) - allocate(ds(2)) + allocate (As(2, 2)) + allocate (bs(2)) + allocate (cs(2)) + allocate (ds(2)) As = 0.d0 bs = 0.d0 cs = 0.d0 ds = 0.d0 - As(1,2) = TWO/3.0d0 + As(1, 2) = TWO/3.0d0 bs(1) = 0.25d0 bs(2) = 0.75d0 cs(2) = TWO/3.0d0 @@ -1017,12 +1015,12 @@ program main ! integration, then prints results. Stops when the final time ! has been reached t = T0 - tout = T0+dTout + tout = T0 + dTout uerr = ZERO verr = ZERO uerrtot = ZERO verrtot = ZERO - errtot = ZERO + errtot = ZERO print *, " t u v uerr verr" print *, " ------------------------------------------------------" print '(A, F10.6, A, F10.6, A, F10.6, A, E9.2, A, E9.2)', & @@ -1034,10 +1032,10 @@ program main call check_retval(retval, "FARKodeEvolve") ! access/print solution and error - uerr = abs(yarr(1)-utrue(tret(1))) - verr = abs(yarr(2)-vtrue(tret(1))) + uerr = abs(yarr(1) - utrue(tret(1))) + verr = abs(yarr(2) - vtrue(tret(1))) print '(A, F10.6, A, F10.6, A, F10.6, A, E9.2, A, E9.2)', & - " ", tret(1), " ", yarr(1), " ", yarr(2), " ", uerr, " ", verr + " ", tret(1), " ", yarr(1), " ", yarr(2), " ", uerr, " ", verr uerrtot = uerrtot + uerr*uerr verrtot = verrtot + verr*verr errtot = errtot + uerr*uerr + verr*verr @@ -1047,10 +1045,10 @@ program main if (tout > Tf) then tout = Tf end if - enddo - uerrtot = sqrt(uerrtot / Nt) - verrtot = sqrt(verrtot / Nt) - errtot = sqrt(errtot / Nt / 2) + end do + uerrtot = sqrt(uerrtot/Nt) + verrtot = sqrt(verrtot/Nt) + errtot = sqrt(errtot/Nt/2) print *, " ------------------------------------------------------" ! @@ -1101,15 +1099,15 @@ program main end if ! Clean up and return - if (allocated(argv)) deallocate(argv) - if (allocated(Af)) deallocate(Af) - if (allocated(bf)) deallocate(bf) - if (allocated(cf)) deallocate(cf) - if (allocated(df)) deallocate(df) - if (allocated(As)) deallocate(As) - if (allocated(bs)) deallocate(bs) - if (allocated(cs)) deallocate(cs) - if (allocated(ds)) deallocate(ds) + if (allocated(argv)) deallocate (argv) + if (allocated(Af)) deallocate (Af) + if (allocated(bf)) deallocate (bf) + if (allocated(cf)) deallocate (cf) + if (allocated(df)) deallocate (df) + if (allocated(As)) deallocate (As) + if (allocated(bs)) deallocate (bs) + if (allocated(cs)) deallocate (cs) + if (allocated(ds)) deallocate (ds) call FN_VDestroy(y) ! Free y vector call FMRIStepCoupling_Free(SC) ! Free coupling coefficients if (associated(MATf)) call FSUNMatDestroy(MATf) ! Free fast matrix @@ -1131,7 +1129,7 @@ subroutine check_retval(retval, name) integer(c_int) :: retval if (retval /= 0) then - write(*,'(A,A,A)') 'ERROR: ', name,' returned nonzero' + write (*, '(A,A,A)') 'ERROR: ', name, ' returned nonzero' stop 1 end if end subroutine check_retval diff --git a/examples/arkode/F2003_serial/ark_roberts_dnsL_f2003.f90 b/examples/arkode/F2003_serial/ark_roberts_dnsL_f2003.f90 index c93a7dc06f..2c5016d2d2 100644 --- a/examples/arkode/F2003_serial/ark_roberts_dnsL_f2003.f90 +++ b/examples/arkode/F2003_serial/ark_roberts_dnsL_f2003.f90 @@ -55,7 +55,7 @@ module dnsL_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function fcnirob(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='fcnirob') + result(ierr) bind(C, name='fcnirob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -67,7 +67,7 @@ integer(c_int) function fcnirob(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! function N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -100,7 +100,7 @@ end function fcnirob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function grob(tn, sunvec_y, gout, user_data) & - result(ierr) bind(C,name='grob') + result(ierr) bind(C, name='grob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -112,7 +112,7 @@ integer(c_int) function grob(tn, sunvec_y, gout, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector real(c_double) :: gout(2) ! root function values - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -142,8 +142,8 @@ end function grob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jacrob(tn, sunvec_y, sunvec_f, & - sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='jacrob') + sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='jacrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -157,14 +157,14 @@ integer(c_int) function jacrob(tn, sunvec_y, sunvec_f, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! residual N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 ! pointers to data in SUNDIALS vector and matrix real(c_double), pointer, dimension(neq) :: yval(:) - real(c_double), pointer, dimension(neq,neq) :: J(:,:) + real(c_double), pointer, dimension(neq, neq) :: J(:, :) !======= Internals ============ @@ -173,15 +173,15 @@ integer(c_int) function jacrob(tn, sunvec_y, sunvec_f, & J(1:3, 1:3) => FSUNDenseMatrix_Data(sunmat_J) ! fill Jacobian entries - J(1,1) = -0.04d0 - J(2,1) = 0.04d0 - J(3,1) = 0.d0 - J(1,2) = 1.d4*yval(3) - J(2,2) = -1.d4*yval(3) - 6.0d7*yval(2) - J(3,2) = 6.d7*yval(2) - J(1,3) = 1.d4*yval(2) - J(2,3) = -1.d4*yval(2) - J(3,3) = 0.d0 + J(1, 1) = -0.04d0 + J(2, 1) = 0.04d0 + J(3, 1) = 0.d0 + J(1, 2) = 1.d4*yval(3) + J(2, 2) = -1.d4*yval(3) - 6.0d7*yval(2) + J(3, 2) = 6.d7*yval(2) + J(1, 3) = 1.d4*yval(2) + J(2, 3) = -1.d4*yval(2) + J(3, 3) = 0.d0 ! return success ierr = 0 @@ -213,12 +213,12 @@ program main real(c_double) :: rtol, t0, tout1, tout, tret(1) integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2) - type(N_Vector), pointer :: sunvec_y ! sundials solution vector - type(N_Vector), pointer :: sunvec_dky ! sundials solution vector - type(N_Vector), pointer :: sunvec_f ! sundials solution vector - type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix - type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_dky ! sundials solution vector + type(N_Vector), pointer :: sunvec_f ! sundials solution vector + type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(SUNNonLinearSolver), pointer :: sunnonlin_NLS ! sundials nonlinear solver type(c_ptr) :: arkode_mem ! ARKODE memory type(c_ptr) :: sunctx ! SUNDIALS simulation context @@ -237,11 +237,11 @@ program main retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) ! initialize solution vectors and tolerances - yval(1) = 1.d0 - yval(2) = 0.d0 - yval(3) = 0.d0 - fval = 0.d0 - rtol = 1.d-4 + yval(1) = 1.d0 + yval(2) = 0.d0 + yval(3) = 0.d0 + fval = 0.d0 + rtol = 1.d-4 avtol(1) = 1.d-8 avtol(2) = 1.d-11 avtol(3) = 1.d-8 @@ -249,20 +249,20 @@ program main ! create serial vectors sunvec_y => FN_VMake_Serial(neq, yval, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_f => FN_VMake_Serial(neq, fval, sunctx) if (.not. associated(sunvec_f)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_av => FN_VMake_Serial(neq, avtol, sunctx) if (.not. associated(sunvec_av)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! set integration limits @@ -278,87 +278,87 @@ program main ! Call FARKodeSVtolerances to set tolerances retval = FARKodeSVtolerances(arkode_mem, rtol, sunvec_av) if (retval /= 0) then - print *, 'Error in FARKodeSVtolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSVtolerances, retval = ', retval, '; halting' + stop 1 end if ! Call FARKodeRootInit to specify the root function grob with 2 components nrtfn = 2 retval = FARKodeRootInit(arkode_mem, nrtfn, c_funloc(grob)) if (retval /= 0) then - print *, 'Error in FARKodeRootInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeRootInit, retval = ', retval, '; halting' + stop 1 end if ! Create dense SUNMatrix for use in linear solves sunmat_A => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! Create dense SUNLinearSolver object sunlinsol_LS => FSUNLinSol_LapackDense(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! Attach the matrix and linear solver - retval = FARKodeSetLinearSolver(arkode_mem, sunlinsol_LS, sunmat_A); + retval = FARKodeSetLinearSolver(arkode_mem, sunlinsol_LS, sunmat_A); if (retval /= 0) then - print *, 'Error in FARKodeSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the user-supplied Jacobian routine retval = FARKodeSetJacFn(arkode_mem, c_funloc(jacrob)) if (retval /= 0) then - print *, 'Error in FARKodeSetJacFn, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSetJacFn, retval = ', retval, '; halting' + stop 1 end if ! Set additional method parameters mxsteps = 10000 retval = FARKodeSetMaxNumSteps(arkode_mem, mxsteps) if (retval /= 0) then - print *, 'Error in FARKodeSetMaxNumSteps' - stop 1 + print *, 'Error in FARKodeSetMaxNumSteps' + stop 1 end if - initsize = 1.d-4 * rtol + initsize = 1.d-4*rtol retval = FARKodeSetInitStep(arkode_mem, initsize) if (retval /= 0) then - print *, 'Error in FARKodeSetInitStep' - stop 1 + print *, 'Error in FARKodeSetInitStep' + stop 1 end if nlscoef = 1.d-7 retval = FARKodeSetNonlinConvCoef(arkode_mem, nlscoef) if (retval /= 0) then - print *, 'Error in FARKodeSetNonlinConvCoef' - stop 1 + print *, 'Error in FARKodeSetNonlinConvCoef' + stop 1 end if nliters = 8 retval = FARKodeSetMaxNonlinIters(arkode_mem, nliters) if (retval /= 0) then - print *, 'Error in FARKodeSetMaxNonlinIters' - stop 1 + print *, 'Error in FARKodeSetMaxNonlinIters' + stop 1 end if pmethod = 1 retval = FARKodeSetPredictorMethod(arkode_mem, pmethod) if (retval /= 0) then - print *, 'Error in FARKodeSetPredictorMethod' - stop 1 + print *, 'Error in FARKodeSetPredictorMethod' + stop 1 end if maxetf = 20 retval = FARKodeSetMaxErrTestFails(arkode_mem, maxetf) if (retval /= 0) then - print *, 'Error in FARKodeSetMaxErrTestFails' - stop 1 + print *, 'Error in FARKodeSetMaxErrTestFails' + stop 1 end if ! Create Newton SUNNonlinearSolver object. ARKODE uses a @@ -367,56 +367,56 @@ program main ! solely for demonstration purposes. sunnonlin_NLS => FSUNNonlinSol_Newton(sunvec_y, sunctx) if (.not. associated(sunnonlin_NLS)) then - print *, 'ERROR: sunnonlinsol = NULL' - stop 1 + print *, 'ERROR: sunnonlinsol = NULL' + stop 1 end if ! Attach the nonlinear solver retval = FARKodeSetNonlinearSolver(arkode_mem, sunnonlin_NLS) if (retval /= 0) then - print *, 'Error in FARKodeSetNonlinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSetNonlinearSolver, retval = ', retval, '; halting' + stop 1 end if ! In loop, call ARKodeEvolve, print results, and test for error. iout = 0 tout = tout1 - do while(iout < nout) + do while (iout < nout) - retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, tret(1), ARK_NORMAL) - if (retval < 0) then - print *, 'Error in FARKodeEvolve, retval = ', retval, '; halting' + retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, tret(1), ARK_NORMAL) + if (retval < 0) then + print *, 'Error in FARKodeEvolve, retval = ', retval, '; halting' + stop 1 + end if + + call PrintOutput(arkode_mem, tret(1), yval) + + if (retval == ARK_ROOT_RETURN) then + retvalr = FARKodeGetRootInfo(arkode_mem, rootsfound) + if (retvalr < 0) then + print *, 'Error in FARKodeGetRootInfo, retval = ', retval, '; halting' stop 1 - endif - - call PrintOutput(arkode_mem, tret(1), yval) - - if (retval .eq. ARK_ROOT_RETURN) then - retvalr = FARKodeGetRootInfo(arkode_mem, rootsfound) - if (retvalr < 0) then - print *, 'Error in FARKodeGetRootInfo, retval = ', retval, '; halting' - stop 1 - endif - print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) - end if - - if (retval .eq. ARK_SUCCESS) then - iout = iout + 1 - tout = tout * 10.d0 - end if + end if + print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) + end if + + if (retval == ARK_SUCCESS) then + iout = iout + 1 + tout = tout*10.d0 + end if end do ! find and print derivative at tret(1) sunvec_dky => FN_VMake_Serial(neq, dkyval, sunctx) if (.not. associated(sunvec_dky)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if retval = FARKodeGetDky(arkode_mem, tret(1), 1, sunvec_dky) if (retval /= 0) then - print *, 'Error in ARKodeGetDky' - stop 1 + print *, 'Error in ARKodeGetDky' + stop 1 end if print *, " " print *, "------------------------------------------------------" @@ -440,7 +440,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -465,8 +464,8 @@ subroutine PrintHeader(rtol, avtol, y) print *, " Three equation chemical kinetics problem." print *, " " print *, "Linear solver: LAPACK DENSE, with user-supplied Jacobian." - print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ",rtol," atol = ", avtol - print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")" + print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ", rtol, " atol = ", avtol + print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (", y, ")" print *, "Constraints not used." print *, " " print *, "----------------------------------------------------------------------" @@ -477,7 +476,6 @@ subroutine PrintHeader(rtol, avtol, y) end subroutine PrintHeader ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -505,23 +503,22 @@ subroutine PrintOutput(arkode_mem, t, y) retval = FARKodeGetNumSteps(arkode_mem, nst) if (retval /= 0) then - print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetLastStep(arkode_mem, hused) if (retval /= 0) then - print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' + stop 1 end if print '(es12.4,1x,3(es12.4,1x),a,i3,2x,es12.4)', & - t, y(1), y(2), y(3), "| ", nst, hused(1) + t, y(1), y(2), y(3), "| ", nst, hused(1) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -561,91 +558,91 @@ subroutine PrintFinalStats(arkode_mem) retval = FARKodeGetNumSteps(arkode_mem, nsteps) if (retval /= 0) then - print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (retval /= 0) then - print *, 'Error in FARKodeGetNumStepAttempts, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumStepAttempts, retval = ', retval, '; halting' + stop 1 end if retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (retval /= 0) then - print *, 'Error in FARKStepGetNumRhsEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKStepGetNumRhsEvals, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetActualInitStep(arkode_mem, hinused) if (retval /= 0) then - print *, 'Error in FARKodeGetActualInitStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetActualInitStep, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetLastStep(arkode_mem, hlast) if (retval /= 0) then - print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetCurrentStep(arkode_mem, hcur) if (retval /= 0) then - print *, 'Error in FARKodeGetCurrentStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentStep, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetCurrentTime(arkode_mem, tcur) if (retval /= 0) then - print *, 'Error in FARKodeGetCurrentTime, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentTime, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumLinSolvSetups(arkode_mem, nlinsetups) if (retval /= 0) then - print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumErrTestFails(arkode_mem, netfails) if (retval /= 0) then - print *, 'Error in FARKodeGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumNonlinSolvIters(arkode_mem, nniters) if (retval /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumNonlinSolvConvFails(arkode_mem, nncfails) if (retval /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumJacEvals(arkode_mem, njacevals) if (retval /= 0) then - print *, 'Error in FARKodeGetNumJacEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumJacEvals, retval = ', retval, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total internal steps attempts =',nst_a - print '(4x,A,i9)' ,'Total rhs exp function calls =',nfe - print '(4x,A,i9)' ,'Total rhs imp function calls =',nfi - print '(4x,A,i9)' ,'Total Jacobian function calls =',njacevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total internal steps attempts =', nst_a + print '(4x,A,i9)', 'Total rhs exp function calls =', nfe + print '(4x,A,i9)', 'Total rhs imp function calls =', nfi + print '(4x,A,i9)', 'Total Jacobian function calls =', njacevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/arkode/F2003_serial/ark_roberts_dns_f2003.f90 b/examples/arkode/F2003_serial/ark_roberts_dns_f2003.f90 index f4ef7e1984..79c3395ffa 100644 --- a/examples/arkode/F2003_serial/ark_roberts_dns_f2003.f90 +++ b/examples/arkode/F2003_serial/ark_roberts_dns_f2003.f90 @@ -55,7 +55,7 @@ module dns_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function fcnirob(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='fcnirob') + result(ierr) bind(C, name='fcnirob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -67,7 +67,7 @@ integer(c_int) function fcnirob(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! function N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -100,7 +100,7 @@ end function fcnirob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function grob(tn, sunvec_y, gout, user_data) & - result(ierr) bind(C,name='grob') + result(ierr) bind(C, name='grob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -113,7 +113,7 @@ integer(c_int) function grob(tn, sunvec_y, gout, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector real(c_double) :: gout(2) ! root function values - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -143,8 +143,8 @@ end function grob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jacrob(tn, sunvec_y, sunvec_f, & - sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='jacrob') + sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='jacrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -159,14 +159,14 @@ integer(c_int) function jacrob(tn, sunvec_y, sunvec_f, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! residual N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 ! pointers to data in SUNDIALS vector and matrix real(c_double), pointer, dimension(neq) :: yval(:) - real(c_double), pointer, dimension(neq,neq) :: J(:,:) + real(c_double), pointer, dimension(neq, neq) :: J(:, :) !======= Internals ============ @@ -175,15 +175,15 @@ integer(c_int) function jacrob(tn, sunvec_y, sunvec_f, & J(1:3, 1:3) => FSUNDenseMatrix_Data(sunmat_J) ! fill Jacobian entries - J(1,1) = -0.04d0 - J(2,1) = 0.04d0 - J(3,1) = 0.d0 - J(1,2) = 1.d4*yval(3) - J(2,2) = -1.d4*yval(3) - 6.0d7*yval(2) - J(3,2) = 6.d7*yval(2) - J(1,3) = 1.d4*yval(2) - J(2,3) = -1.d4*yval(2) - J(3,3) = 0.d0 + J(1, 1) = -0.04d0 + J(2, 1) = 0.04d0 + J(3, 1) = 0.d0 + J(1, 2) = 1.d4*yval(3) + J(2, 2) = -1.d4*yval(3) - 6.0d7*yval(2) + J(3, 2) = 6.d7*yval(2) + J(1, 3) = 1.d4*yval(2) + J(2, 3) = -1.d4*yval(2) + J(3, 3) = 0.d0 ! return success ierr = 0 @@ -195,7 +195,6 @@ end function jacrob end module dns_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -216,12 +215,12 @@ program main real(c_double) :: rtol, t0, tout1, tout, tret(1) integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2) - type(N_Vector), pointer :: sunvec_y ! sundials solution vector - type(N_Vector), pointer :: sunvec_dky ! sundials solution vector - type(N_Vector), pointer :: sunvec_f ! sundials solution vector - type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix - type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_dky ! sundials solution vector + type(N_Vector), pointer :: sunvec_f ! sundials solution vector + type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(SUNNonLinearSolver), pointer :: sunnonlin_NLS ! sundials nonlinear solver type(c_ptr) :: arkode_mem ! ARKODE memory type(c_ptr) :: sunctx ! SUNDIALS simulation context @@ -240,11 +239,11 @@ program main retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) ! initialize solution vectors and tolerances - yval(1) = 1.d0 - yval(2) = 0.d0 - yval(3) = 0.d0 - fval = 0.d0 - rtol = 1.d-4 + yval(1) = 1.d0 + yval(2) = 0.d0 + yval(3) = 0.d0 + fval = 0.d0 + rtol = 1.d-4 avtol(1) = 1.d-8 avtol(2) = 1.d-11 avtol(3) = 1.d-8 @@ -252,20 +251,20 @@ program main ! create serial vectors sunvec_y => FN_VMake_Serial(neq, yval, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_f => FN_VMake_Serial(neq, fval, sunctx) if (.not. associated(sunvec_f)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_av => FN_VMake_Serial(neq, avtol, sunctx) if (.not. associated(sunvec_av)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! set integration limits @@ -281,87 +280,87 @@ program main ! Call FARKodeSVtolerances to set tolerances retval = FARKodeSVtolerances(arkode_mem, rtol, sunvec_av) if (retval /= 0) then - print *, 'Error in FARKodeSVtolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSVtolerances, retval = ', retval, '; halting' + stop 1 end if ! Call FARKodeRootInit to specify the root function grob with 2 components nrtfn = 2 retval = FARKodeRootInit(arkode_mem, nrtfn, c_funloc(grob)) if (retval /= 0) then - print *, 'Error in FARKodeRootInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeRootInit, retval = ', retval, '; halting' + stop 1 end if ! Create dense SUNMatrix for use in linear solves sunmat_A => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! Create dense SUNLinearSolver object sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! Attach the matrix and linear solver - retval = FARKodeSetLinearSolver(arkode_mem, sunlinsol_LS, sunmat_A); + retval = FARKodeSetLinearSolver(arkode_mem, sunlinsol_LS, sunmat_A); if (retval /= 0) then - print *, 'Error in FARKodeSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the user-supplied Jacobian routine retval = FARKodeSetJacFn(arkode_mem, c_funloc(jacrob)) if (retval /= 0) then - print *, 'Error in FARKodeSetJacFn, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSetJacFn, retval = ', retval, '; halting' + stop 1 end if ! Set additional method parameters mxsteps = 10000 retval = FARKodeSetMaxNumSteps(arkode_mem, mxsteps) if (retval /= 0) then - print *, 'Error in FARKodeSetMaxNumSteps' - stop 1 + print *, 'Error in FARKodeSetMaxNumSteps' + stop 1 end if - initsize = 1.d-4 * rtol + initsize = 1.d-4*rtol retval = FARKodeSetInitStep(arkode_mem, initsize) if (retval /= 0) then - print *, 'Error in FARKodeSetInitStep' - stop 1 + print *, 'Error in FARKodeSetInitStep' + stop 1 end if nlscoef = 1.d-7 retval = FARKodeSetNonlinConvCoef(arkode_mem, nlscoef) if (retval /= 0) then - print *, 'Error in FARKodeSetNonlinConvCoef' - stop 1 + print *, 'Error in FARKodeSetNonlinConvCoef' + stop 1 end if nliters = 8 retval = FARKodeSetMaxNonlinIters(arkode_mem, nliters) if (retval /= 0) then - print *, 'Error in FARKodeSetMaxNonlinIters' - stop 1 + print *, 'Error in FARKodeSetMaxNonlinIters' + stop 1 end if pmethod = 1 retval = FARKodeSetPredictorMethod(arkode_mem, pmethod) if (retval /= 0) then - print *, 'Error in FARKodeSetPredictorMethod' - stop 1 + print *, 'Error in FARKodeSetPredictorMethod' + stop 1 end if maxetf = 20 retval = FARKodeSetMaxErrTestFails(arkode_mem, maxetf) if (retval /= 0) then - print *, 'Error in FARKodeSetMaxErrTestFails' - stop 1 + print *, 'Error in FARKodeSetMaxErrTestFails' + stop 1 end if ! Create Newton SUNNonlinearSolver object. ARKODE uses a @@ -370,56 +369,56 @@ program main ! solely for demonstration purposes. sunnonlin_NLS => FSUNNonlinSol_Newton(sunvec_y, sunctx) if (.not. associated(sunnonlin_NLS)) then - print *, 'ERROR: sunnonlinsol = NULL' - stop 1 + print *, 'ERROR: sunnonlinsol = NULL' + stop 1 end if ! Attach the nonlinear solver retval = FARKodeSetNonlinearSolver(arkode_mem, sunnonlin_NLS) if (retval /= 0) then - print *, 'Error in FARKodeSetNonlinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeSetNonlinearSolver, retval = ', retval, '; halting' + stop 1 end if ! In loop, call ARKodeEvolve, print results, and test for error. iout = 0 tout = tout1 - do while(iout < nout) + do while (iout < nout) + + retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, tret(1), ARK_NORMAL) + if (retval < 0) then + print *, 'Error in FARKodeEvolve, retval = ', retval, '; halting' + stop 1 + end if + + call PrintOutput(arkode_mem, tret(1), yval) - retval = FARKodeEvolve(arkode_mem, tout, sunvec_y, tret(1), ARK_NORMAL) - if (retval < 0) then - print *, 'Error in FARKodeEvolve, retval = ', retval, '; halting' + if (retval == ARK_ROOT_RETURN) then + retvalr = FARKodeGetRootInfo(arkode_mem, rootsfound) + if (retvalr < 0) then + print *, 'Error in FARKodeGetRootInfo, retval = ', retval, '; halting' stop 1 - endif - - call PrintOutput(arkode_mem, tret(1), yval) - - if (retval .eq. ARK_ROOT_RETURN) then - retvalr = FARKodeGetRootInfo(arkode_mem, rootsfound) - if (retvalr < 0) then - print *, 'Error in FARKodeGetRootInfo, retval = ', retval, '; halting' - stop 1 - endif - print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) - end if - - if (retval .eq. ARK_SUCCESS) then - iout = iout + 1 - tout = tout * 10.d0 - end if + end if + print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) + end if + + if (retval == ARK_SUCCESS) then + iout = iout + 1 + tout = tout*10.d0 + end if end do ! find and print derivative at tret(1) sunvec_dky => FN_VMake_Serial(neq, dkyval, sunctx) if (.not. associated(sunvec_dky)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if retval = FARKodeGetDky(arkode_mem, tret(1), 1, sunvec_dky) if (retval /= 0) then - print *, 'Error in ARKodeGetDky' - stop 1 + print *, 'Error in ARKodeGetDky' + stop 1 end if print *, " " print *, "------------------------------------------------------" @@ -443,7 +442,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -468,8 +466,8 @@ subroutine PrintHeader(rtol, avtol, y) print *, " Three equation chemical kinetics problem." print *, " " print *, "Linear solver: DENSE, with user-supplied Jacobian." - print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ",rtol," atol = ", avtol - print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")" + print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ", rtol, " atol = ", avtol + print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (", y, ")" print *, "Constraints not used." print *, " " print *, "----------------------------------------------------------------------" @@ -480,7 +478,6 @@ subroutine PrintHeader(rtol, avtol, y) end subroutine PrintHeader ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -508,23 +505,22 @@ subroutine PrintOutput(arkode_mem, t, y) retval = FARKodeGetNumSteps(arkode_mem, nst) if (retval /= 0) then - print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetLastStep(arkode_mem, hused) if (retval /= 0) then - print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' + stop 1 end if print '(es12.4,1x,3(es12.4,1x),a,i3,2x,es12.4)', & - t, y(1), y(2), y(3), "| ", nst, hused(1) + t, y(1), y(2), y(3), "| ", nst, hused(1) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -564,91 +560,91 @@ subroutine PrintFinalStats(arkode_mem) retval = FARKodeGetNumSteps(arkode_mem, nsteps) if (retval /= 0) then - print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumStepAttempts(arkode_mem, nst_a) if (retval /= 0) then - print *, 'Error in FARKodeGetNumStepAttempts, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumStepAttempts, retval = ', retval, '; halting' + stop 1 end if retval = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi) if (retval /= 0) then - print *, 'Error in FARKStepGetNumRhsEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKStepGetNumRhsEvals, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetActualInitStep(arkode_mem, hinused) if (retval /= 0) then - print *, 'Error in FARKodeGetActualInitStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetActualInitStep, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetLastStep(arkode_mem, hlast) if (retval /= 0) then - print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetLastStep, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetCurrentStep(arkode_mem, hcur) if (retval /= 0) then - print *, 'Error in FARKodeGetCurrentStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentStep, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetCurrentTime(arkode_mem, tcur) if (retval /= 0) then - print *, 'Error in FARKodeGetCurrentTime, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetCurrentTime, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumLinSolvSetups(arkode_mem, nlinsetups) if (retval /= 0) then - print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumLinSolvSetups, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumErrTestFails(arkode_mem, netfails) if (retval /= 0) then - print *, 'Error in FARKodeGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumNonlinSolvIters(arkode_mem, nniters) if (retval /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumNonlinSolvConvFails(arkode_mem, nncfails) if (retval /= 0) then - print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FARKodeGetNumJacEvals(arkode_mem, njacevals) if (retval /= 0) then - print *, 'Error in FARKodeGetNumJacEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FARKodeGetNumJacEvals, retval = ', retval, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total internal steps attempts =',nst_a - print '(4x,A,i9)' ,'Total rhs exp function calls =',nfe - print '(4x,A,i9)' ,'Total rhs imp function calls =',nfi - print '(4x,A,i9)' ,'Total Jacobian function calls =',njacevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total internal steps attempts =', nst_a + print '(4x,A,i9)', 'Total rhs exp function calls =', nfe + print '(4x,A,i9)', 'Total rhs imp function calls =', nfi + print '(4x,A,i9)', 'Total Jacobian function calls =', njacevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/arkode/F2003_serial/test_ark_butcher_f2003.f90 b/examples/arkode/F2003_serial/test_ark_butcher_f2003.f90 index 0bc1bafdfa..7d3ee72e33 100644 --- a/examples/arkode/F2003_serial/test_ark_butcher_f2003.f90 +++ b/examples/arkode/F2003_serial/test_ark_butcher_f2003.f90 @@ -22,7 +22,7 @@ module test_arkode_butcher_table integer, parameter :: myindextype = selected_int_kind(16) #endif - contains +contains integer function smoke_tests() result(ret) @@ -52,7 +52,7 @@ integer function smoke_tests() result(ret) d(1) = 1.0d0 !===== Test ===== - ERK = FARkodeButcherTable_LoadERK(ARKODE_HEUN_EULER_2_1_2) + ERK = FARkodeButcherTable_LoadERK(ARKODE_HEUN_EULER_2_1_2) DIRK = FARkodeButcherTable_LoadDIRK(ARKODE_SDIRK_2_1_2) ierr = FARkodeButcherTable_CheckOrder(ERK, q, p, C_NULL_PTR) ierr = FARkodeButcherTable_CheckARKOrder(ERK, DIRK, q, p, C_NULL_PTR) @@ -60,10 +60,10 @@ integer function smoke_tests() result(ret) call FARKodeButcherTable_Free(ERK) call FARKodeButcherTable_Free(DIRK) - ERK = FARkodeButcherTable_Create(2, 2, 1, c, A, b, d) - DIRK = FARkodeButcherTable_Alloc(2, 1) + ERK = FARkodeButcherTable_Create(2, 2, 1, c, A, b, d) + DIRK = FARkodeButcherTable_Alloc(2, 1) call FARKodeButcherTable_Free(DIRK) - DIRK = FARkodeButcherTable_Copy(ERK) + DIRK = FARkodeButcherTable_Copy(ERK) !==== Cleanup ===== call FARKodeButcherTable_Free(ERK) @@ -75,7 +75,6 @@ end function smoke_tests end module - program main !======== Inclusions ========== use, intrinsic :: iso_c_binding diff --git a/examples/cvode/F2003_parallel/cv_diag_kry_bbd_f2003.f90 b/examples/cvode/F2003_parallel/cv_diag_kry_bbd_f2003.f90 index 98d9110884..52ca72d685 100644 --- a/examples/cvode/F2003_parallel/cv_diag_kry_bbd_f2003.f90 +++ b/examples/cvode/F2003_parallel/cv_diag_kry_bbd_f2003.f90 @@ -21,10 +21,46 @@ !----------------------------------------------------------------- module DiagkrybbdData - !--------------------------------------------------------------- - ! Description: - ! Module containing problem-defining parameters. - !--------------------------------------------------------------- + !--------------------------------------------------------------- + ! Description: + ! Module containing problem-defining parameters. + !--------------------------------------------------------------- + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + + !======= Declarations ========= + implicit none + + ! With MPI-3 use mpi_f08 is preferred + include "mpif.h" + + save + + ! SUNDIALS simulation context + type(c_ptr) :: sunctx + + ! MPI domain decomposition information + integer, target :: comm ! communicator object + integer :: myid ! MPI process ID + integer :: nprocs ! total number of MPI processes + + ! Problem parameters + integer(c_int), parameter :: iGStype = 1 + integer(c_int), parameter :: iPretype0 = 1 + integer(c_int64_t), parameter :: nlocal = 10 + integer(c_int64_t) :: neq, mu, ml, mudq, mldq + integer(c_int) :: iPretype + real(c_double) :: alpha + +contains + + !----------------------------------------------------------------- + ! ODE RHS function f(t,y) (implicit). + !----------------------------------------------------------------- + integer(c_int) function firhs(t, sunvec_y, sunvec_ydot, user_data) & + result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -33,473 +69,434 @@ module DiagkrybbdData !======= Declarations ========= implicit none - ! With MPI-3 use mpi_f08 is preferred - include "mpif.h" + ! calling variables + real(c_double), value :: t ! current time + type(N_Vector) :: sunvec_y ! solution N_Vector + type(N_Vector) :: sunvec_ydot ! rhs N_Vector + type(c_ptr) :: user_data ! user-defined data - save + ! pointers to data in SUNDIALS vectors + real(c_double), pointer :: y(:) + real(c_double), pointer :: ydot(:) - ! SUNDIALS simulation context - type(c_ptr) :: sunctx + ! local data + integer :: i - ! MPI domain decomposition information - integer, target :: comm ! communicator object - integer :: myid ! MPI process ID - integer :: nprocs ! total number of MPI processes + !======= Internals ============ - ! Problem parameters - integer(c_int), parameter :: iGStype = 1 - integer(c_int), parameter :: iPretype0 = 1 - integer(c_int64_t), parameter :: nlocal = 10 - integer(c_int64_t) :: neq, mu, ml, mudq, mldq - integer(c_int) :: iPretype - real(c_double) :: alpha + ! Get data arrays from SUNDIALS vectors + y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) + ydot(1:nlocal) => FN_VGetArrayPointer(sunvec_ydot) - contains + ! Initialize ydot to zero + ydot = 0.d0 + ! Fill ydot with rhs function + do i = 1, nlocal + ydot(i) = -alpha*(myid*nlocal + i)*y(i) + end do + retval = 0 ! Return with success + return + end function firhs + !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! ODE RHS function f(t,y) (implicit). - !----------------------------------------------------------------- - integer(c_int) function firhs(t, sunvec_y, sunvec_ydot, user_data) & - result(retval) bind(C) + !----------------------------------------------------------------- + ! ODE RHS function used for BBD preconditioner. + !----------------------------------------------------------------- + integer(c_int) function LocalgFn(nnlocal, t, sunvec_y, sunvec_g, user_data) & + result(retval) bind(C) - !======= Inclusions =========== - use, intrinsic :: iso_c_binding - use fsundials_core_mod + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod - !======= Declarations ========= - implicit none + !======= Declarations ========= + implicit none - ! calling variables - real(c_double), value :: t ! current time - type(N_Vector) :: sunvec_y ! solution N_Vector - type(N_Vector) :: sunvec_ydot ! rhs N_Vector - type(c_ptr) :: user_data ! user-defined data + ! calling variables + real(c_double), value :: t ! current time + integer(c_int64_t) :: nnlocal ! local space + type(N_Vector) :: sunvec_y ! solution N_Vector + type(N_Vector) :: sunvec_g ! output g N_Vector + type(c_ptr) :: user_data ! user-defined data - ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: y(:) - real(c_double), pointer :: ydot(:) + ! local data + integer :: ierr - ! local data - integer :: i + ierr = firhs(t, sunvec_y, sunvec_g, user_data) + if (ierr /= 0) then + write (0, *) "Error in firhs user-defined function, ierr = ", ierr + stop 1 + end if - !======= Internals ============ + retval = 0 ! Return with success + return + end function LocalgFn + !----------------------------------------------------------------- - ! Get data arrays from SUNDIALS vectors - y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) - ydot(1:nlocal) => FN_VGetArrayPointer(sunvec_ydot) +end module DiagkrybbdData +!----------------------------------------------------------------- - ! Initialize ydot to zero - ydot = 0.d0 +!----------------------------------------------------------------- +! Main driver program +!----------------------------------------------------------------- +program driver + + ! inclusions + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fcvode_mod ! Access CVode + use fnvector_parallel_mod ! Access parallel N_Vector + use fsunlinsol_spgmr_mod ! Fortran interface to spgmr SUNLinearSolver + + use DiagkrybbdData + + !======= Declarations ========= + implicit none + + ! Declarations + ! general problem parameters + integer, parameter :: Nt = 10 ! total number of output times + real(c_double), parameter :: T0 = 0.d0 ! initial time + real(c_double), parameter :: Tf = 1.d0 ! final time + real(c_double), parameter :: rtol = 1.d-5 ! relative and absolute tolerances + real(c_double), parameter :: atol = 1.d-10 + + ! solution vector and other local variables + type(SUNLinearSolver), pointer :: sunls ! sundials linear solver + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(N_Vector), pointer :: sunvec_y ! solution N_Vector + real(c_double), pointer :: y(:) ! vector data + type(c_ptr) :: cvode_mem ! CVODE memory + integer(c_int) :: retval + integer :: ierr + logical :: outproc + real(c_double) :: t(1), dTout, tout + integer(c_long) :: nst(1) ! number of time steps + integer(c_long) :: nfe(1) ! number of RHS evals + integer(c_long) :: netf(1) ! number of error test fails + integer(c_long) :: nni(1) ! number of nonlinear iters + integer(c_long) :: ncfn(1) ! number of nonlinear convergence fails + integer(c_long) :: ncfl(1) ! number of linear convergence fails + integer(c_long) :: nli(1) ! number of linear iters + integer(c_long) :: npre(1) ! number of preconditioner setups + integer(c_long) :: npsol(1) ! number of preconditioner solves + integer(c_long) :: lenrw(1) ! main solver real/int workspace size + integer(c_long) :: leniw(1) + integer(c_long) :: lenrwls(1) ! linear solver real/int workspace size + integer(c_long) :: leniwls(1) + integer(c_long) :: ngebbd(1) ! num g evaluations + double precision :: avdim(1) ! avg Krylov subspace dim (NLI/NNI) + integer(c_long) :: lenrwbbd(1) ! band preconditioner real/int workspace size + integer(c_long) :: leniwbbd(1) + integer :: i, ioutput + real(c_double) :: errmax, erri, gerrmax + + ! Initialize MPI variables + comm = MPI_COMM_WORLD + myid = 0 + nprocs = 0 + + ! initialize MPI + call MPI_Init(ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Init = ", ierr + stop 1 + end if + call MPI_Comm_size(comm, nprocs, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Comm_size = ", ierr + call MPI_Abort(comm, 1, ierr) + end if + call MPI_Comm_rank(comm, myid, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) + end if + + ! Set input arguments neq and alpha + neq = nprocs*nlocal + alpha = 10.0d0 + + ! Create SUNDIALS simulation context, now that comm has been configured + retval = FSUNContext_Create(comm, sunctx) + if (retval /= 0) then + print *, "Error: FSUNContext_Create returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Initial problem output + outproc = (myid == 0) + if (outproc) then + write (6, *) " " + write (6, *) "Diagonal test problem:"; + write (6, '(A,i4)') " neq = ", neq + write (6, '(A,i4)') " nlocal = ", nlocal + write (6, '(A,i4)') " nprocs = ", nprocs + write (6, '(A,es9.2)') " rtol = ", rtol + write (6, '(A,es9.2)') " atol = ", atol + write (6, '(A,es9.2)') " alpha = ", alpha + write (6, *) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" + write (6, *) " Method is BDF/NEWTON/SPGMR" + write (6, *) " Precond is band-block-diagonal, using CVBBDPRE" + write (6, *) " " + end if + + ! Create solution vector, point at its data, and set initial condition + sunvec_y => FN_VNew_Parallel(comm, nlocal, neq, sunctx) + y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) + y = 1.d0 + + ! Create the CVode timestepper module + cvode_mem = FCVodeCreate(CV_BDF, sunctx) + if (.not. c_associated(cvode_mem)) then + print *, "Error: FCVodeCreate returned NULL" + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeInit(cvode_mem, c_funloc(firhs), t0, sunvec_y) + if (retval /= 0) then + print *, "Error: FCVodeInit returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Tell CVODE to use a SPGMR linear solver. + sunls => FSUNLinSol_SPGMR(sunvec_y, iPretype0, 0, sunctx) + if (.not. associated(sunls)) then + print *, 'ERROR: sunls = NULL' + call MPI_Abort(comm, 1, ierr) + end if + + ! Attach the linear solver (with NULL SUNMatrix object) + sunmat_A => null() + retval = FCVodeSetLinearSolver(cvode_mem, sunls, sunmat_A) + if (retval /= 0) then + print *, 'Error in FCVodeSetLinearSolver, retval = ', retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FSUNLinSol_SPGMRSetGSType(sunls, iGStype) + if (retval /= 0) then + print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Specify tolerances + retval = FCVodeSStolerances(cvode_mem, rtol, atol) + if (retval /= 0) then + print *, "Error: FCVodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + mu = 0 + ml = 0 + mudq = 0 + mldq = 0 + retval = FCVBBDPrecInit(cvode_mem, nlocal, mudq, mldq, mu, ml, 0.d0, & + c_funloc(LocalgFn), c_null_funptr) + if (retval /= 0) then + print *, "Error: FCVBBDPrecInit returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + do iPretype = 1, 2 + + if (iPretype == 2) then + + y = 1.d0 + + retval = FCVodeReInit(cvode_mem, t0, sunvec_y) + if (retval /= 0) then + print *, "Error in FCVodeReInit, retval = ", retval + call MPI_Abort(comm, 1, ierr) + end if - ! Fill ydot with rhs function - do i = 1,nlocal - ydot(i) = -alpha * (myid * nlocal + i) * y(i) - end do + retval = FCVBBDPrecReInit(cvode_mem, mudq, mldq, 0.d0) + if (retval /= 0) then + print *, "Error in FCVBBDPrecReInit, retval = ", retval + call MPI_Abort(comm, 1, ierr) + end if - retval = 0 ! Return with success - return - end function firhs - !----------------------------------------------------------------- + retval = FSUNLinSol_SPGMRSetPrecType(sunls, iPretype) + if (retval /= 0) then + print *, "Error in FSUNLinSol_SPGMRSetPrecType, retval = ", retval + call MPI_Abort(comm, 1, ierr) + end if - !----------------------------------------------------------------- - ! ODE RHS function used for BBD preconditioner. - !----------------------------------------------------------------- - integer(c_int) function LocalgFn(nnlocal, t, sunvec_y, sunvec_g, user_data) & - result(retval) bind(C) + if (outproc) write (6, *) " Preconditioning on right:" - !======= Inclusions =========== - use, intrinsic :: iso_c_binding - use fsundials_core_mod + end if - !======= Declarations ========= - implicit none + if (iPretype == 1 .and. outproc) write (6, *) " Preconditioning on left:" - ! calling variables - real(c_double), value :: t ! current time - integer(c_int64_t) :: nnlocal ! local space - type(N_Vector) :: sunvec_y ! solution N_Vector - type(N_Vector) :: sunvec_g ! output g N_Vector - type(c_ptr) :: user_data ! user-defined data + ! Main time-stepping loop: calls CVode to perform the integration, then + ! prints results. Stops when the final time has been reached + t(1) = T0 + dTout = 0.1d0 + tout = T0 + dTout + if (outproc) then + write (6, *) " t steps fe" + write (6, *) " --------------------------------" + end if + do ioutput = 1, Nt - ! local data - integer :: ierr + ! Integrate to output time + retval = FCVode(cvode_mem, tout, sunvec_y, t, CV_NORMAL) + if (retval /= 0) then + print *, "Error: FCVode returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - ierr = firhs(t, sunvec_y, sunvec_g, user_data) - if (ierr /= 0) then - write(0,*) "Error in firhs user-defined function, ierr = ", ierr - stop 1 + retval = FCVodeGetNumSteps(cvode_mem, nst) + if (retval /= 0) then + print *, "Error: FCVodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if - retval = 0 ! Return with success - return - end function LocalgFn - !----------------------------------------------------------------- + retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) + if (retval /= 0) then + print *, "Error: FCVodeGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - end module DiagkrybbdData - !----------------------------------------------------------------- + ! print solution stats and update internal time + if (outproc) write (6, '(3x,f10.6,3(3x,i6))') t, nst, nfe + tout = min(tout + dTout, Tf) + end do + if (outproc) then + write (6, *) " --------------------------------" + end if - !----------------------------------------------------------------- - ! Main driver program - !----------------------------------------------------------------- - program driver + ! Get max. absolute error in the local vector. + errmax = 0.d0 + do i = 1, nlocal + erri = y(i) - exp(-alpha*(myid*nlocal + i)*t(1)) + errmax = max(errmax, abs(erri)) + end do - ! inclusions - use, intrinsic :: iso_c_binding - use fsundials_core_mod - use fcvode_mod ! Access CVode - use fnvector_parallel_mod ! Access parallel N_Vector - use fsunlinsol_spgmr_mod ! Fortran interface to spgmr SUNLinearSolver + ! Get global max. error from MPI_Reduce call. + call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & + 0, comm, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error in MPI_Reduce = ", ierr + call MPI_Abort(comm, 1, ierr) + end if - use DiagkrybbdData + ! Print global max. error + if (outproc) print '(a,es10.2)', "Max. absolute error is ", gerrmax - !======= Declarations ========= - implicit none + ! Get final statistics + retval = FCVodeGetNumSteps(cvode_mem, nst) + if (retval /= 0) then + print *, "Error: FCVodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - ! Declarations - ! general problem parameters - integer, parameter :: Nt = 10 ! total number of output times - real(c_double), parameter :: T0 = 0.d0 ! initial time - real(c_double), parameter :: Tf = 1.d0 ! final time - real(c_double), parameter :: rtol = 1.d-5 ! relative and absolute tolerances - real(c_double), parameter :: atol = 1.d-10 - - ! solution vector and other local variables - type(SUNLinearSolver), pointer :: sunls ! sundials linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) - type(N_Vector), pointer :: sunvec_y ! solution N_Vector - real(c_double), pointer :: y(:) ! vector data - type(c_ptr) :: cvode_mem ! CVODE memory - integer(c_int) :: retval - integer :: ierr - logical :: outproc - real(c_double) :: t(1), dTout, tout - integer(c_long) :: nst(1) ! number of time steps - integer(c_long) :: nfe(1) ! number of RHS evals - integer(c_long) :: netf(1) ! number of error test fails - integer(c_long) :: nni(1) ! number of nonlinear iters - integer(c_long) :: ncfn(1) ! number of nonlinear convergence fails - integer(c_long) :: ncfl(1) ! number of linear convergence fails - integer(c_long) :: nli(1) ! number of linear iters - integer(c_long) :: npre(1) ! number of preconditioner setups - integer(c_long) :: npsol(1) ! number of preconditioner solves - integer(c_long) :: lenrw(1) ! main solver real/int workspace size - integer(c_long) :: leniw(1) - integer(c_long) :: lenrwls(1) ! linear solver real/int workspace size - integer(c_long) :: leniwls(1) - integer(c_long) :: ngebbd(1) ! num g evaluations - double precision :: avdim(1) ! avg Krylov subspace dim (NLI/NNI) - integer(c_long) :: lenrwbbd(1) ! band preconditioner real/int workspace size - integer(c_long) :: leniwbbd(1) - integer :: i, ioutput - real(c_double) :: errmax, erri, gerrmax - - ! Initialize MPI variables - comm = MPI_COMM_WORLD - myid = 0 - nprocs = 0 - - ! initialize MPI - call MPI_Init(ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) + if (retval /= 0) then + print *, "Error: FCVodeGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if - call MPI_Comm_size(comm, nprocs, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = ", ierr - call MPI_Abort(comm, 1, ierr) + + retval = FCVodeGetNumPrecEvals(cvode_mem, npre) + if (retval /= 0) then + print *, "Error: FCVodeGetNumPrecEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if - call MPI_Comm_rank(comm, myid, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + + retval = FCVodeGetNumPrecSolves(cvode_mem, npsol) + if (retval /= 0) then + print *, "Error: FCVodeGetNumPrecSolves returned ", retval + call MPI_Abort(comm, 1, ierr) end if - ! Set input arguments neq and alpha - neq = nprocs * nlocal - alpha = 10.0d0 + retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nni) + if (retval /= 0) then + print *, "Error: FCVodeGetNumNonlinSolvIters returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - ! Create SUNDIALS simulation context, now that comm has been configured - retval = FSUNContext_Create(comm, sunctx) + retval = FCVodeGetNumLinIters(cvode_mem, nli) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ", retval + print *, "Error: FCVodeGetNumLinIters returned ", retval call MPI_Abort(comm, 1, ierr) end if - ! Initial problem output - outproc = (myid == 0) - if (outproc) then - write(6,*) " " - write(6,*) "Diagonal test problem:"; - write(6,'(A,i4)') " neq = " , neq - write(6,'(A,i4)') " nlocal = " , nlocal - write(6,'(A,i4)') " nprocs = " , nprocs - write(6,'(A,es9.2)') " rtol = ", rtol - write(6,'(A,es9.2)') " atol = ", atol - write(6,'(A,es9.2)') " alpha = ", alpha - write(6,*) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" - write(6,*) " Method is BDF/NEWTON/SPGMR" - write(6,*) " Precond is band-block-diagonal, using CVBBDPRE" - write(6,*) " " - endif - - ! Create solution vector, point at its data, and set initial condition - sunvec_y => FN_VNew_Parallel(comm, nlocal, neq, sunctx) - y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) - y = 1.d0 + avdim = dble(nli)/dble(nni) - ! Create the CVode timestepper module - cvode_mem = FCVodeCreate(CV_BDF, sunctx) - if (.not. c_associated(cvode_mem)) then - print *, "Error: FCVodeCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, ncfn) + if (retval /= 0) then + print *, "Error: FCVodeGetNumNonlinSolvConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if - retval = FCVodeInit(cvode_mem, c_funloc(firhs), t0, sunvec_y) + retval = FCVodeGetNumLinConvFails(cvode_mem, ncfl) if (retval /= 0) then - print *, "Error: FCVodeInit returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeGetNumLinSolvConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if - ! Tell CVODE to use a SPGMR linear solver. - sunls => FSUNLinSol_SPGMR(sunvec_y, iPretype0, 0, sunctx) - if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - call MPI_Abort(comm, 1, ierr) + retval = FCVodeGetNumErrTestFails(cvode_mem, netf) + if (retval /= 0) then + print *, "Error: FCVodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if - ! Attach the linear solver (with NULL SUNMatrix object) - sunmat_A => null() - retval = FCVodeSetLinearSolver(cvode_mem, sunls, sunmat_A) + retval = FCVodeGetWorkSpace(cvode_mem, lenrw, leniw) if (retval /= 0) then - print *, 'Error in FCVodeSetLinearSolver, retval = ', retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeGetWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) end if - retval = FSUNLinSol_SPGMRSetGSType(sunls, iGStype) + retval = FCVodeGetLinWorkSpace(cvode_mem, lenrwls, leniwls) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeGetLinWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) end if - ! Specify tolerances - retval = FCVodeSStolerances(cvode_mem, rtol, atol) + retval = FCVBBDPrecGetWorkSpace(cvode_mem, lenrwbbd, leniwbbd) if (retval /= 0) then - print *, "Error: FCVodeSStolerances returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVBBDPrecGetWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) end if - mu = 0 - ml = 0 - mudq = 0 - mldq = 0 - retval = FCVBBDPrecInit(cvode_mem, nlocal, mudq, mldq, mu, ml, 0.d0, & - c_funloc(LocalgFn), c_null_funptr) + retval = FCVBBDPrecGetNumGfnEvals(cvode_mem, ngebbd) if (retval /= 0) then - print *, "Error: FCVBBDPrecInit returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVBBDPrecGetNumGfnEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if - do iPretype = 1,2 - - if (iPretype == 2) then - - y = 1.d0 - - retval = FCVodeReInit(cvode_mem, t0, sunvec_y) - if (retval /= 0) then - print *, "Error in FCVodeReInit, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVBBDPrecReInit(cvode_mem, mudq, mldq, 0.d0) - if (retval /= 0) then - print *, "Error in FCVBBDPrecReInit, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FSUNLinSol_SPGMRSetPrecType(sunls, iPretype) - if (retval /= 0) then - print *, "Error in FSUNLinSol_SPGMRSetPrecType, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - if (outproc) write(6,*) " Preconditioning on right:" - - end if - - if (iPretype == 1 .and. outproc) write(6,*) " Preconditioning on left:" - - ! Main time-stepping loop: calls CVode to perform the integration, then - ! prints results. Stops when the final time has been reached - t(1) = T0 - dTout = 0.1d0 - tout = T0+dTout - if (outproc) then - write(6,*) " t steps fe" - write(6,*) " --------------------------------" - end if - do ioutput=1,Nt - - ! Integrate to output time - retval = FCVode(cvode_mem, tout, sunvec_y, t, CV_NORMAL) - if (retval /= 0) then - print *, "Error: FCVode returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumSteps(cvode_mem, nst) - if (retval /= 0) then - print *, "Error: FCVodeGetNumSteps returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) - if (retval /= 0) then - print *, "Error: FCVodeGetNumRhsEvals returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - ! print solution stats and update internal time - if (outproc) write(6,'(3x,f10.6,3(3x,i6))') t, nst, nfe - tout = min(tout + dTout, Tf) - - end do - if (outproc) then - write(6,*) " --------------------------------" - end if - - ! Get max. absolute error in the local vector. - errmax = 0.d0 - do i = 1,nlocal - erri = y(i) - exp(-alpha * (myid * nlocal + i) * t(1)) - errmax = max(errmax, abs(erri)) - end do - - ! Get global max. error from MPI_Reduce call. - call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & - 0, comm, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error in MPI_Reduce = ", ierr - call MPI_Abort(comm, 1, ierr) - end if - - ! Print global max. error - if (outproc) print '(a,es10.2)', "Max. absolute error is ", gerrmax - - ! Get final statistics - retval = FCVodeGetNumSteps(cvode_mem, nst) - if (retval /= 0) then - print *, "Error: FCVodeGetNumSteps returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) - if (retval /= 0) then - print *, "Error: FCVodeGetNumRhsEvals returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumPrecEvals(cvode_mem, npre) - if (retval /= 0) then - print *, "Error: FCVodeGetNumPrecEvals returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumPrecSolves(cvode_mem, npsol) - if (retval /= 0) then - print *, "Error: FCVodeGetNumPrecSolves returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nni) - if (retval /= 0) then - print *, "Error: FCVodeGetNumNonlinSolvIters returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumLinIters(cvode_mem, nli) - if (retval /= 0) then - print *, "Error: FCVodeGetNumLinIters returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - avdim = dble(nli) / dble(nni) - - retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, ncfn) - if (retval /= 0) then - print *, "Error: FCVodeGetNumNonlinSolvConvFails returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumLinConvFails(cvode_mem, ncfl) - if (retval /= 0) then - print *, "Error: FCVodeGetNumLinSolvConvFails returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumErrTestFails(cvode_mem, netf) - if (retval /= 0) then - print *, "Error: FCVodeGetNumErrTestFails returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetWorkSpace(cvode_mem, lenrw, leniw) - if (retval /= 0) then - print *, "Error: FCVodeGetWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetLinWorkSpace(cvode_mem, lenrwls, leniwls) - if (retval /= 0) then - print *, "Error: FCVodeGetLinWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVBBDPrecGetWorkSpace(cvode_mem, lenrwbbd, leniwbbd) - if (retval /= 0) then - print *, "Error: FCVBBDPrecGetWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVBBDPrecGetNumGfnEvals(cvode_mem, ngebbd) - if (retval /= 0) then - print *, "Error: FCVBBDPrecGetNumGfnEvals returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Print some final statistics - if (outproc) then - write(6,*) " " - write(6,*) "Final Solver Statistics:" - write(6,'(A,i6)') " Internal solver steps = ", nst - write(6,'(A,i6)') " Total RHS evals = ", nfe - write(6,'(A,i6)') " Total preconditioner setups = ", npre - write(6,'(A,i6)') " Total preconditioner solves = ", npsol - write(6,'(A,i6)') " Total nonlinear iterations = ", nni - write(6,'(A,i6)') " Total linear iterations = ", nli - write(6,'(A,f8.4)') " Average Krylov subspace dimension = ", avdim - write(6,'(A,i6)') " Total Convergence Failures - Nonlinear = ", ncfn - write(6,'(A,i6)') " - Linear = ", ncfl - write(6,'(A,i6)') " Total number of error test failures = ", netf - write(6,'(A,2i6)') " Main solver real/int workspace sizes = ", lenrw, leniw - write(6,'(A,2i6)') " Linear solver real/int workspace sizes = ", lenrwls, leniwls - write(6,'(A,2i6)') " BBD preconditioner real/int workspace sizes = ", lenrwbbd, leniwbbd - write(6,'(A,i6)') " Total number of g evals = ", ngebbd - write(6,'(A)') " " - write(6,'(A)') " " - write(6,'(A)') " " - end if - end do + ! Print some final statistics + if (outproc) then + write (6, *) " " + write (6, *) "Final Solver Statistics:" + write (6, '(A,i6)') " Internal solver steps = ", nst + write (6, '(A,i6)') " Total RHS evals = ", nfe + write (6, '(A,i6)') " Total preconditioner setups = ", npre + write (6, '(A,i6)') " Total preconditioner solves = ", npsol + write (6, '(A,i6)') " Total nonlinear iterations = ", nni + write (6, '(A,i6)') " Total linear iterations = ", nli + write (6, '(A,f8.4)') " Average Krylov subspace dimension = ", avdim + write (6, '(A,i6)') " Total Convergence Failures - Nonlinear = ", ncfn + write (6, '(A,i6)') " - Linear = ", ncfl + write (6, '(A,i6)') " Total number of error test failures = ", netf + write (6, '(A,2i6)') " Main solver real/int workspace sizes = ", lenrw, leniw + write (6, '(A,2i6)') " Linear solver real/int workspace sizes = ", lenrwls, leniwls + write (6, '(A,2i6)') " BBD preconditioner real/int workspace sizes = ", lenrwbbd, leniwbbd + write (6, '(A,i6)') " Total number of g evals = ", ngebbd + write (6, '(A)') " " + write (6, '(A)') " " + write (6, '(A)') " " + end if + end do - ! Clean up and return with successful completion - call FCVodeFree(cvode_mem) ! free integrator memory - call FN_VDestroy(sunvec_y) ! free vector memory - call MPI_Barrier(comm, ierr) - call MPI_Finalize(ierr) ! Finalize MPI + ! Clean up and return with successful completion + call FCVodeFree(cvode_mem) ! free integrator memory + call FN_VDestroy(sunvec_y) ! free vector memory + call MPI_Barrier(comm, ierr) + call MPI_Finalize(ierr) ! Finalize MPI - end program driver - !----------------------------------------------------------------- +end program driver +!----------------------------------------------------------------- diff --git a/examples/cvode/F2003_parallel/cv_diag_kry_f2003.f90 b/examples/cvode/F2003_parallel/cv_diag_kry_f2003.f90 index 38cf788bdc..2a8ca17ca1 100644 --- a/examples/cvode/F2003_parallel/cv_diag_kry_f2003.f90 +++ b/examples/cvode/F2003_parallel/cv_diag_kry_f2003.f90 @@ -47,8 +47,8 @@ module DiagkryData integer :: nprocs ! total number of MPI processes ! Problem parameters - integer(c_int), parameter :: iGStype = 1 - integer(c_int), parameter :: iPretype0 = 1 + integer(c_int), parameter :: iGStype = 1 + integer(c_int), parameter :: iPretype0 = 1 integer(c_int64_t), parameter :: nlocal = 10 integer(c_int64_t) :: neq integer(c_int) :: iPretype @@ -60,7 +60,7 @@ module DiagkryData ! ODE RHS function f(t,y) (implicit). ! ---------------------------------------------------------------- integer(c_int) function firhs(t, sunvec_y, sunvec_ydot, user_data) & - result(retval) bind(C) + result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -73,7 +73,7 @@ integer(c_int) function firhs(t, sunvec_y, sunvec_ydot, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(nlocal) :: y(:) @@ -85,15 +85,15 @@ integer(c_int) function firhs(t, sunvec_y, sunvec_ydot, user_data) & !======= Internals ============ ! Get data arrays from SUNDIALS vectors - y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) + y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) ydot(1:nlocal) => FN_VGetArrayPointer(sunvec_ydot) ! Initialize ydot to zero ydot = 0.d0 ! Fill ydot with rhs function - do i = 1,nlocal - ydot(i) = -alpha * (myid * nlocal + i) * y(i) + do i = 1, nlocal + ydot(i) = -alpha*(myid*nlocal + i)*y(i) end do retval = 0 ! Return with success @@ -110,7 +110,7 @@ end function firhs ! local vector segment) is applied to the vector z. ! ---------------------------------------------------------------- integer(c_int) function Psolve(t, sunvec_y, sunvec_f, sunvec_r, sunvec_z, & - gamma, delta, lr, user_data) result(retval) bind(C) + gamma, delta, lr, user_data) result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -128,7 +128,7 @@ integer(c_int) function Psolve(t, sunvec_y, sunvec_f, sunvec_r, sunvec_z, & real(c_double), value :: gamma ! current gamma value real(c_double), value :: delta ! current delta value integer(c_int), value :: lr ! left or right preconditioning - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(nlocal) :: z(:) @@ -148,12 +148,12 @@ integer(c_int) function Psolve(t, sunvec_y, sunvec_f, sunvec_r, sunvec_z, & z = r ! Calculate Jacobian here - ibase = myid * nlocal + ibase = myid*nlocal istart = max(1_c_int64_t, 4 - ibase) - do i = istart,nlocal - pj = dble(ibase + i) - psubi = 1.d0 + gamma * alpha * pj - z(i) = z(i) / psubi + do i = istart, nlocal + pj = dble(ibase + i) + psubi = 1.d0 + gamma*alpha*pj + z(i) = z(i)/psubi end do retval = 0 ! Return with success @@ -164,7 +164,6 @@ end function Psolve end module DiagkryData ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -224,47 +223,47 @@ program driver ! initialize MPI call MPI_Init(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + write (0, *) "Error in MPI_Init = ", ierr + stop 1 end if call MPI_Comm_size(comm, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_size = ", ierr + call MPI_Abort(comm, 1, ierr) end if call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Set input arguments neq and alpha - neq = nprocs * nlocal + neq = nprocs*nlocal alpha = 10.0d0 ! Create SUNDIALS simulation context, now that comm has been configured retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNContext_Create returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Initial problem output outproc = (myid == 0) if (outproc) then - write(6,*) " " - write(6,*) "Diagonal test problem:"; - write(6,'(A,i4)') " neq = " , neq - write(6,'(A,i4)') " nlocal = " , nlocal - write(6,'(A,i4)') " nprocs = " , nprocs - write(6,'(A,es9.2)') " rtol = ", rtol - write(6,'(A,es9.2)') " atol = ", atol - write(6,'(A,es9.2)') " alpha = ", alpha - write(6,*) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" - write(6,*) " Method is BDF/NEWTON/SPGMR" - write(6,*) " Diagonal preconditioner uses approximate Jacobian" - write(6,*) " " - endif + write (6, *) " " + write (6, *) "Diagonal test problem:"; + write (6, '(A,i4)') " neq = ", neq + write (6, '(A,i4)') " nlocal = ", nlocal + write (6, '(A,i4)') " nprocs = ", nprocs + write (6, '(A,es9.2)') " rtol = ", rtol + write (6, '(A,es9.2)') " atol = ", atol + write (6, '(A,es9.2)') " alpha = ", alpha + write (6, *) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" + write (6, *) " Method is BDF/NEWTON/SPGMR" + write (6, *) " Diagonal preconditioner uses approximate Jacobian" + write (6, *) " " + end if ! Create solution vector, point at its data, and set initial condition sunvec_y => FN_VNew_Parallel(comm, nlocal, neq, sunctx) @@ -274,220 +273,220 @@ program driver ! Create the CVode timestepper module cvode_mem = FCVodeCreate(CV_BDF, sunctx) if (.not. c_associated(cvode_mem)) then - print *, "Error: FCVodeCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeCreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if retval = FCVodeInit(cvode_mem, c_funloc(firhs), t0, sunvec_y) if (retval /= 0) then - print *, "Error: FCVodeInit returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeInit returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Tell CVODE to use a SPGMR linear solver. sunls => FSUNLinSol_SPGMR(sunvec_y, iPretype0, 0, sunctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - call MPI_Abort(comm, 1, ierr) + print *, 'ERROR: sunls = NULL' + call MPI_Abort(comm, 1, ierr) end if ! Attach the linear solver (with NULL SUNMatrix object) sunmat_A => null() retval = FCVodeSetLinearSolver(cvode_mem, sunls, sunmat_A) if (retval /= 0) then - print *, 'Error in FCVodeSetLinearSolver, retval = ', retval - call MPI_Abort(comm, 1, ierr) + print *, 'Error in FCVodeSetLinearSolver, retval = ', retval + call MPI_Abort(comm, 1, ierr) end if retval = FSUNLinSol_SPGMRSetGSType(sunls, iGStype) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval - call MPI_Abort(comm, 1, ierr) + print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FCVodeSStolerances(cvode_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FCVodeSStolerances returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FCVodeSetPreconditioner(cvode_mem, c_null_funptr, c_funloc(Psolve)) if (retval /= 0) then - print *, "Error: FCVodeSetPreconditioner returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeSetPreconditioner returned ", retval + call MPI_Abort(comm, 1, ierr) end if - do iPretype = 1,2 - - if (iPretype == 2) then - - y = 1.d0 - - retval = FCVodeReInit(cvode_mem, t0, sunvec_y) - if (retval /= 0) then - print *, "Error in FCVodeReInit, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FSUNLinSol_SPGMRSetPrecType(sunls, iPretype) - if (retval /= 0) then - print *, "Error in FSUNLinSol_SPGMRSetPrecType, retval = ", retval - call MPI_Abort(comm, 1, ierr) - end if - - if (outproc) write(6,*) " Preconditioning on right:" - - end if - - if (iPretype == 1 .and. outproc) write(6,*) " Preconditioning on left:" - - ! Main time-stepping loop: calls CVode to perform the integration, then - ! prints results. Stops when the final time has been reached - t(1) = T0 - dTout = 0.1d0 - tout = T0+dTout - if (outproc) then - write(6,*) " t steps fe" - write(6,*) " --------------------------------" - end if - do ioutput=1,Nt - - ! Integrate to output time - retval = FCVode(cvode_mem, tout, sunvec_y, t, CV_NORMAL) - if (retval /= 0) then - print *, "Error: FCVode returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumSteps(cvode_mem, nst) - if (retval /= 0) then - print *, "Error: FCVodeGetNumSteps returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) - if (retval /= 0) then - print *, "Error: FCVodeGetNumRhsEvals returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - ! print solution stats and update internal time - if (outproc) write(6,'(3x,f10.6,3(3x,i6))') t, nst, nfe - tout = min(tout + dTout, Tf) - - end do - if (outproc) then - write(6,*) " --------------------------------" - end if - - ! Get max. absolute error in the local vector. - errmax = 0.d0 - do i = 1,nlocal - erri = y(i) - exp(-alpha * (myid * nlocal + i) * t(1)) - errmax = max(errmax, abs(erri)) - end do - - ! Get global max. error from MPI_Reduce call. - call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & - 0, comm, ierr) - if (ierr /= MPI_SUCCESS) then - print *, "Error in MPI_Reduce = ", ierr - call MPI_Abort(comm, 1, ierr) - end if + do iPretype = 1, 2 - ! Print global max. error - if (outproc) print '(a,es10.2)', "Max. absolute error is ", gerrmax + if (iPretype == 2) then - ! Get final statistics - retval = FCVodeGetNumSteps(cvode_mem, nst) - if (retval /= 0) then - print *, "Error: FCVodeGetNumSteps returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + y = 1.d0 - retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) - if (retval /= 0) then - print *, "Error: FCVodeGetNumRhsEvals returned ", retval + retval = FCVodeReInit(cvode_mem, t0, sunvec_y) + if (retval /= 0) then + print *, "Error in FCVodeReInit, retval = ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FCVodeGetNumPrecEvals(cvode_mem, npre) - if (retval /= 0) then - print *, "Error: FCVodeGetNumPrecEvals returned ", retval + retval = FSUNLinSol_SPGMRSetPrecType(sunls, iPretype) + if (retval /= 0) then + print *, "Error in FSUNLinSol_SPGMRSetPrecType, retval = ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FCVodeGetNumPrecSolves(cvode_mem, npsol) - if (retval /= 0) then - print *, "Error: FCVodeGetNumPrecSolves returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + if (outproc) write (6, *) " Preconditioning on right:" - retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nni) - if (retval /= 0) then - print *, "Error: FCVodeGetNumNonlinSolvIters returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FCVodeGetNumLinIters(cvode_mem, nli) - if (retval /= 0) then - print *, "Error: FCVodeGetNumLinIters returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + if (iPretype == 1 .and. outproc) write (6, *) " Preconditioning on left:" - avdim = dble(nli) / dble(nni) + ! Main time-stepping loop: calls CVode to perform the integration, then + ! prints results. Stops when the final time has been reached + t(1) = T0 + dTout = 0.1d0 + tout = T0 + dTout + if (outproc) then + write (6, *) " t steps fe" + write (6, *) " --------------------------------" + end if + do ioutput = 1, Nt - retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, ncfn) - if (retval /= 0) then - print *, "Error: FCVodeGetNumNonlinSolvConvFails returned ", retval + ! Integrate to output time + retval = FCVode(cvode_mem, tout, sunvec_y, t, CV_NORMAL) + if (retval /= 0) then + print *, "Error: FCVode returned ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FCVodeGetNumLinConvFails(cvode_mem, ncfl) - if (retval /= 0) then - print *, "Error: FCVodeGetNumLinSolvConvFails returned ", retval + retval = FCVodeGetNumSteps(cvode_mem, nst) + if (retval /= 0) then + print *, "Error: FCVodeGetNumSteps returned ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FCVodeGetNumErrTestFails(cvode_mem, netf) - if (retval /= 0) then - print *, "Error: FCVodeGetNumErrTestFails returned ", retval + retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) + if (retval /= 0) then + print *, "Error: FCVodeGetNumRhsEvals returned ", retval call MPI_Abort(comm, 1, ierr) - end if + end if - retval = FCVodeGetWorkSpace(cvode_mem, lenrw, leniw) - if (retval /= 0) then - print *, "Error: FCVodeGetWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if + ! print solution stats and update internal time + if (outproc) write (6, '(3x,f10.6,3(3x,i6))') t, nst, nfe + tout = min(tout + dTout, Tf) - retval = FCVodeGetLinWorkSpace(cvode_mem, lenrwls, leniwls) - if (retval /= 0) then - print *, "Error: FCVodeGetLinWorkSpace returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Print some final statistics - if (outproc) then - write(6,*) " " - write(6,*) "Final Solver Statistics:" - write(6,'(A,i6)') " Internal solver steps = ", nst - write(6,'(A,i6)') " Total RHS evals = ", nfe - write(6,'(A,i6)') " Total preconditioner setups = ", npre - write(6,'(A,i6)') " Total preconditioner solves = ", npsol - write(6,'(A,i6)') " Total nonlinear iterations = ", nni - write(6,'(A,i6)') " Total linear iterations = ", nli - write(6,'(A,f8.4)') " Average Krylov subspace dimension = ", avdim - write(6,'(A,i6)') " Total Convergence Failures - Nonlinear = ", ncfn - write(6,'(A,i6)') " - Linear = ", ncfl - write(6,'(A,i6)') " Total number of error test failures = ", netf - write(6,'(A,2i6)') " Main solver real/int workspace sizes = ", lenrw, leniw - write(6,'(A,2i6)') " Linear solver real/int workspace sizes = ", lenrwls, leniwls - write(6,'(A)') " " - write(6,'(A)') " " - write(6,'(A)') " " - end if + end do + if (outproc) then + write (6, *) " --------------------------------" + end if + + ! Get max. absolute error in the local vector. + errmax = 0.d0 + do i = 1, nlocal + erri = y(i) - exp(-alpha*(myid*nlocal + i)*t(1)) + errmax = max(errmax, abs(erri)) + end do + + ! Get global max. error from MPI_Reduce call. + call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & + 0, comm, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "Error in MPI_Reduce = ", ierr + call MPI_Abort(comm, 1, ierr) + end if + + ! Print global max. error + if (outproc) print '(a,es10.2)', "Max. absolute error is ", gerrmax + + ! Get final statistics + retval = FCVodeGetNumSteps(cvode_mem, nst) + if (retval /= 0) then + print *, "Error: FCVodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) + if (retval /= 0) then + print *, "Error: FCVodeGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumPrecEvals(cvode_mem, npre) + if (retval /= 0) then + print *, "Error: FCVodeGetNumPrecEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumPrecSolves(cvode_mem, npsol) + if (retval /= 0) then + print *, "Error: FCVodeGetNumPrecSolves returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nni) + if (retval /= 0) then + print *, "Error: FCVodeGetNumNonlinSolvIters returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumLinIters(cvode_mem, nli) + if (retval /= 0) then + print *, "Error: FCVodeGetNumLinIters returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + avdim = dble(nli)/dble(nni) + + retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, ncfn) + if (retval /= 0) then + print *, "Error: FCVodeGetNumNonlinSolvConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumLinConvFails(cvode_mem, ncfl) + if (retval /= 0) then + print *, "Error: FCVodeGetNumLinSolvConvFails returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumErrTestFails(cvode_mem, netf) + if (retval /= 0) then + print *, "Error: FCVodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetWorkSpace(cvode_mem, lenrw, leniw) + if (retval /= 0) then + print *, "Error: FCVodeGetWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetLinWorkSpace(cvode_mem, lenrwls, leniwls) + if (retval /= 0) then + print *, "Error: FCVodeGetLinWorkSpace returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Print some final statistics + if (outproc) then + write (6, *) " " + write (6, *) "Final Solver Statistics:" + write (6, '(A,i6)') " Internal solver steps = ", nst + write (6, '(A,i6)') " Total RHS evals = ", nfe + write (6, '(A,i6)') " Total preconditioner setups = ", npre + write (6, '(A,i6)') " Total preconditioner solves = ", npsol + write (6, '(A,i6)') " Total nonlinear iterations = ", nni + write (6, '(A,i6)') " Total linear iterations = ", nli + write (6, '(A,f8.4)') " Average Krylov subspace dimension = ", avdim + write (6, '(A,i6)') " Total Convergence Failures - Nonlinear = ", ncfn + write (6, '(A,i6)') " - Linear = ", ncfl + write (6, '(A,i6)') " Total number of error test failures = ", netf + write (6, '(A,2i6)') " Main solver real/int workspace sizes = ", lenrw, leniw + write (6, '(A,2i6)') " Linear solver real/int workspace sizes = ", lenrwls, leniwls + write (6, '(A)') " " + write (6, '(A)') " " + write (6, '(A)') " " + end if end do ! Clean up and return with successful completion diff --git a/examples/cvode/F2003_parallel/cv_diag_non_p_f2003.f90 b/examples/cvode/F2003_parallel/cv_diag_non_p_f2003.f90 index 8f200c90c7..bea02183c3 100644 --- a/examples/cvode/F2003_parallel/cv_diag_non_p_f2003.f90 +++ b/examples/cvode/F2003_parallel/cv_diag_non_p_f2003.f90 @@ -55,7 +55,7 @@ module DiagnonData ! ODE RHS function f(t,y). ! ---------------------------------------------------------------- integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & - result(retval) bind(C) + result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -68,7 +68,7 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(nlocal) :: y(:) @@ -80,15 +80,15 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & !======= Internals ============ ! Get data arrays from SUNDIALS vectors - y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) + y(1:nlocal) => FN_VGetArrayPointer(sunvec_y) ydot(1:nlocal) => FN_VGetArrayPointer(sunvec_ydot) ! Initialize ydot to zero ydot = 0.d0 ! Fill ydot with rhs function - do i = 1,nlocal - ydot(i) = -alpha * (myid * nlocal + i) * y(i) + do i = 1, nlocal + ydot(i) = -alpha*(myid*nlocal + i)*y(i) end do retval = 0 ! Return with success @@ -96,11 +96,9 @@ integer(c_int) function frhs(t, sunvec_y, sunvec_ydot, user_data) & end function frhs ! ---------------------------------------------------------------- - end module DiagnonData ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Main driver program ! ---------------------------------------------------------------- @@ -149,46 +147,46 @@ program driver ! initialize MPI call MPI_Init(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + write (0, *) "Error in MPI_Init = ", ierr + stop 1 end if call MPI_Comm_size(comm, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_size = ", ierr + call MPI_Abort(comm, 1, ierr) end if call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Set input arguments neq and alpha - neq = nprocs * nlocal - alpha = 10.0d0 / neq + neq = nprocs*nlocal + alpha = 10.0d0/neq ! Create SUNDIALS simulation context, now that comm has been configured retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNContext_Create returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Initial problem output outproc = (myid == 0) if (outproc) then - write(6,*) " " - write(6,*) "Diagonal test problem:"; - write(6,'(A,i4)') " neq = " , neq - write(6,'(A,i4)') " nlocal = " , nlocal - write(6,'(A,i4)') " nprocs = " , nprocs - write(6,'(A,es9.2)') " rtol = ", rtol - write(6,'(A,es9.2)') " atol = ", atol - write(6,'(A,es9.2)') " alpha = ", alpha - write(6,*) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" - write(6,*) " Method is ADAMS/FIXED-POINT" - write(6,*) " " - endif + write (6, *) " " + write (6, *) "Diagonal test problem:"; + write (6, '(A,i4)') " neq = ", neq + write (6, '(A,i4)') " nlocal = ", nlocal + write (6, '(A,i4)') " nprocs = ", nprocs + write (6, '(A,es9.2)') " rtol = ", rtol + write (6, '(A,es9.2)') " atol = ", atol + write (6, '(A,es9.2)') " alpha = ", alpha + write (6, *) " ydot_i = -alpha*i * y_i (i = 1,...,neq)" + write (6, *) " Method is ADAMS/FIXED-POINT" + write (6, *) " " + end if ! Create solution vector, point at its data, and set initial condition sunvec_y => FN_VNew_Parallel(comm, nlocal, neq, sunctx) @@ -198,88 +196,88 @@ program driver ! Create and Initialize the CVode timestepper module cvode_mem = FCVodeCreate(CV_ADAMS, sunctx) if (.not. c_associated(cvode_mem)) then - print *, "Error: FCVodeCreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeCreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if retval = FCVodeInit(cvode_mem, c_funloc(frhs), t0, sunvec_y) if (retval /= 0) then - print *, "Error: FCVodeInit returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeInit returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Assign and Setup SUNDIALS Nonlinear solver sunnls => FSUNNonlinSol_FixedPoint(sunvec_y, 0, sunctx) if (.not. associated(sunnls)) then - print *, 'ERROR: sunnls = NULL' - call MPI_Abort(comm, 1, ierr) + print *, 'ERROR: sunnls = NULL' + call MPI_Abort(comm, 1, ierr) end if retval = FCVodeSetNonlinearSolver(cvode_mem, sunnls) if (retval /= 0) then - print *, 'Error in FCVodeSetNonlinearSolver, retval = ', retval - call MPI_Abort(comm, 1, ierr) + print *, 'Error in FCVodeSetNonlinearSolver, retval = ', retval + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FCVodeSStolerances(cvode_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FCVodeSStolerances returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeSStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Main time-stepping loop: calls CVode to perform the integration, then ! prints results. Stops when the final time has been reached t(1) = T0 dTout = 0.1d0 - tout = T0+dTout + tout = T0 + dTout if (outproc) then - write(6,*) " t steps fe" - write(6,*) " ----------------------------" + write (6, *) " t steps fe" + write (6, *) " ----------------------------" end if - do ioutput=1,Nt - - ! Integrate to output time - retval = FCVode(cvode_mem, tout, sunvec_y, t, CV_NORMAL) - if (retval /= 0) then - print *, "Error: FCVode returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumSteps(cvode_mem, nst) - if (retval /= 0) then - print *, "Error: FCVodeGetNumSteps returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) - if (retval /= 0) then - print *, "Error: FCVodeGetNumRhsEvals returned ", retval - call MPI_Abort(comm, 1, ierr) - end if - - ! print solution stats and update internal time - if (outproc) write(6,'(3x,f10.6,2(3x,i5))') t, nst, nfe - tout = min(tout + dTout, Tf) + do ioutput = 1, Nt + + ! Integrate to output time + retval = FCVode(cvode_mem, tout, sunvec_y, t, CV_NORMAL) + if (retval /= 0) then + print *, "Error: FCVode returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumSteps(cvode_mem, nst) + if (retval /= 0) then + print *, "Error: FCVodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) + if (retval /= 0) then + print *, "Error: FCVodeGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! print solution stats and update internal time + if (outproc) write (6, '(3x,f10.6,2(3x,i5))') t, nst, nfe + tout = min(tout + dTout, Tf) end do if (outproc) then - write(6,*) " --------------------------------" + write (6, *) " --------------------------------" end if ! Get max. absolute error in the local vector. errmax = 0.d0 - do i = 1,nlocal - erri = y(i) - exp(-alpha * (myid * nlocal + i) * t(1)) - errmax = max(errmax, abs(erri)) + do i = 1, nlocal + erri = y(i) - exp(-alpha*(myid*nlocal + i)*t(1)) + errmax = max(errmax, abs(erri)) end do ! Get global max. error from MPI_Reduce call. call MPI_Reduce(errmax, gerrmax, 1, MPI_DOUBLE, MPI_MAX, & - 0, comm, ierr) + 0, comm, ierr) if (ierr /= MPI_SUCCESS) then - print *, "Error in MPI_Reduce = ", ierr - call MPI_Abort(comm, 1, ierr) + print *, "Error in MPI_Reduce = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Print global max. error @@ -288,30 +286,30 @@ program driver ! Get final statistics retval = FCVodeGetNumSteps(cvode_mem, nst) if (retval /= 0) then - print *, "Error: FCVodeGetNumSteps returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (retval /= 0) then - print *, "Error: FCVodeGetNumRhsEvals returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeGetNumRhsEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FCVodeGetNumErrTestFails(cvode_mem, netf) if (retval /= 0) then - print *, "Error: FCVodeGetNumErrTestFails returned ", retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FCVodeGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Print some final statistics if (outproc) then - write(6,*) " " - write(6,*) "Final Solver Statistics:" - write(6,'(A,i6)') " Internal solver steps = ", nst - write(6,'(A,i6)') " Total RHS evals = ", nfe - write(6,'(A,i6)') " Total number of error test failures = ", netf - endif + write (6, *) " " + write (6, *) "Final Solver Statistics:" + write (6, '(A,i6)') " Internal solver steps = ", nst + write (6, '(A,i6)') " Total RHS evals = ", nfe + write (6, '(A,i6)') " Total number of error test failures = ", netf + end if ! Clean up and return with successful completion call FCVodeFree(cvode_mem) ! free integrator memory diff --git a/examples/cvode/F2003_serial/cv_advdiff_bnd_f2003.f90 b/examples/cvode/F2003_serial/cv_advdiff_bnd_f2003.f90 index 423ef44f12..32ca2ead64 100644 --- a/examples/cvode/F2003_serial/cv_advdiff_bnd_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_advdiff_bnd_f2003.f90 @@ -60,11 +60,11 @@ module advdiff_mod ! ODE constant parameters real(c_double), parameter :: xmax = 2.0d0, ymax = 1.0d0 real(c_double), parameter :: dtout = 0.1d0 - real(c_double), parameter :: dx = xmax / (mx + 1) - real(c_double), parameter :: dy = ymax / (my + 1) - real(c_double), parameter :: hdcoef = 1.0d0 / (dx * dx) - real(c_double), parameter :: hacoef = 0.5d0 / (2.0d0 * dx) - real(c_double), parameter :: vdcoef = 1.0d0 / (dy * dy) + real(c_double), parameter :: dx = xmax/(mx + 1) + real(c_double), parameter :: dy = ymax/(my + 1) + real(c_double), parameter :: hdcoef = 1.0d0/(dx*dx) + real(c_double), parameter :: hacoef = 0.5d0/(2.0d0*dx) + real(c_double), parameter :: vdcoef = 1.0d0/(dy*dy) ! Solving assistance fixed parameters real(c_double), parameter :: rtol = 0.0d0 @@ -87,7 +87,7 @@ module advdiff_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -99,43 +99,43 @@ integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local data real(c_double) :: uij, udn, uup, ult, urt, hdiff, hadv, vdiff ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(mx,my) :: uvec(:,:) - real(c_double), pointer, dimension(mx,my) :: fvec(:,:) + real(c_double), pointer, dimension(mx, my) :: uvec(:, :) + real(c_double), pointer, dimension(mx, my) :: fvec(:, :) !======= Internals ============ ! get data arrays from SUNDIALS vectors - uvec(1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) - fvec(1:mx,1:my) => FN_VGetArrayPointer(sunvec_f) + uvec(1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) + fvec(1:mx, 1:my) => FN_VGetArrayPointer(sunvec_f) ! Loop over all grid points do i = 1, mx - do j = 1, my - - ! Extract u at x_i, y_j and four neighboring points. - uij = uvec(i,j) - udn = 0.0d0 - if (j .ne. 1) udn = uvec(i, j-1) - uup = 0.0d0 - if (j .ne. my) uup = uvec(i, j+1) - ult = 0.0d0 - if (i .ne. 1) ult = uvec(i-1, j) - urt = 0.0d0 - if (i .ne. mx) urt = uvec(i+1, j) - - ! Set diffusion and advection terms and load into fvec. - hdiff = hdcoef * (ult - 2.0d0 * uij + urt) - hadv = hacoef * (urt - ult) - vdiff = vdcoef * (uup - 2.0d0 * uij + udn) - fvec(i,j) = hdiff + hadv + vdiff - - end do + do j = 1, my + + ! Extract u at x_i, y_j and four neighboring points. + uij = uvec(i, j) + udn = 0.0d0 + if (j /= 1) udn = uvec(i, j - 1) + uup = 0.0d0 + if (j /= my) uup = uvec(i, j + 1) + ult = 0.0d0 + if (i /= 1) ult = uvec(i - 1, j) + urt = 0.0d0 + if (i /= mx) urt = uvec(i + 1, j) + + ! Set diffusion and advection terms and load into fvec. + hdiff = hdcoef*(ult - 2.0d0*uij + urt) + hadv = hacoef*(urt - ult) + vdiff = vdcoef*(uup - 2.0d0*uij + udn) + fvec(i, j) = hdiff + hadv + vdiff + + end do end do ! return success @@ -155,8 +155,8 @@ end function RhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function JacFn(t, sunvec_u, sunvec_f, sunmat_J, & - user_data, sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) & - bind(C,name='JacFn') + user_data, sunvec_t1, sunvec_t2, sunvec_t3) result(ierr) & + bind(C, name='JacFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -170,7 +170,7 @@ integer(c_int) function JacFn(t, sunvec_u, sunvec_f, sunmat_J, & type(N_Vector) :: sunvec_u type(N_Vector) :: sunvec_f type(SUNMatrix) :: sunmat_J - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data type(N_Vector) :: sunvec_t1 type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 @@ -178,31 +178,31 @@ integer(c_int) function JacFn(t, sunvec_u, sunvec_f, sunmat_J, & ! local data integer(kind=myindextype) :: mband, k, ioff, mu1, mu2, smu, mdim integer(kind=myindextype) :: start - real(c_double), pointer, dimension(mdim,neq) :: Jmat(:,:) + real(c_double), pointer, dimension(mdim, neq) :: Jmat(:, :) smu = FSUNBandMatrix_StoredUpperBandwidth(sunmat_J) mdim = smu + 1 + ml - Jmat(1:mdim,1:neq) => FSUNBandMatrix_Data(sunmat_J) + Jmat(1:mdim, 1:neq) => FSUNBandMatrix_Data(sunmat_J) mu1 = smu + 1 mu2 = smu + 2 mband = smu + 1 + ml - start = smu-mu+1 + start = smu - mu + 1 ! Loop over all grid points do i = 1, mx - ioff = (i - 1) * my - do j = 1, my - k = j + ioff - - ! Set Jacobian elements in column k of J. - Jmat(mu1,k) = -2.0d0 * (vdcoef + hdcoef) - if (i /= 1) Jmat(start,k) = hdcoef + hacoef - if (i /= mx) Jmat(mband,k) = hdcoef - hacoef - if (j /= 1) Jmat(smu,k) = vdcoef - if (j /= my) Jmat(mu2,k) = vdcoef - - end do + ioff = (i - 1)*my + do j = 1, my + k = j + ioff + + ! Set Jacobian elements in column k of J. + Jmat(mu1, k) = -2.0d0*(vdcoef + hdcoef) + if (i /= 1) Jmat(start, k) = hdcoef + hacoef + if (i /= mx) Jmat(mband, k) = hdcoef - hacoef + if (j /= 1) Jmat(smu, k) = vdcoef + if (j /= my) Jmat(mu2, k) = vdcoef + + end do end do ! return success @@ -215,7 +215,6 @@ end function JacFn end module advdiff_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -238,11 +237,11 @@ program main integer(c_int) :: ierr ! error flag from C functions integer(c_long) :: outstep ! output step - type(N_Vector), pointer :: sunvec_u ! sundials vector + type(N_Vector), pointer :: sunvec_u ! sundials vector type(SUNLinearSolver), pointer :: sunls ! sundials linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) type(c_ptr) :: cvode_mem ! CVODE memory - real(c_double), pointer, dimension(mx,my) :: u(:,:) ! underlying vector + real(c_double), pointer, dimension(mx, my) :: u(:, :) ! underlying vector ! output statistic variables integer(c_long) :: lnst(1) @@ -254,67 +253,67 @@ program main ! initialize ODE tstart = 0.0d0 - tcur = tstart + tcur = tstart mu = my ml = my ! create SUNDIALS N_Vector sunvec_u => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - u(1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) + u(1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) ! initialize and fill initial condition vector do i = 1, mx - x = i * dx - do j = 1, my - y = j * dy - u(i,j) = x * (xmax - x) * y * (ymax - y) * exp(5.0d0 * x * y) - end do + x = i*dx + do j = 1, my + y = j*dy + u(i, j) = x*(xmax - x)*y*(ymax - y)*exp(5.0d0*x*y) + end do end do ! create and initialize CVode memory cvode_mem = FCVodeCreate(CV_BDF, ctx) - if (.not. c_associated(cvode_mem)) print *,'ERROR: cvode_mem = NULL' + if (.not. c_associated(cvode_mem)) print *, 'ERROR: cvode_mem = NULL' ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_u) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! Tell CVODE to use a Band linear solver. sunmat_A => FSUNBandMatrix(neq, mu, ml, ctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if sunls => FSUNLinSol_Band(sunvec_u, sunmat_A, ctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - stop 1 + print *, 'ERROR: sunls = NULL' + stop 1 end if ! Attach the linear solver (with NULL SUNMatrix object) ierr = FCVodeSetLinearSolver(cvode_mem, sunls, sunmat_A) if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeSetJacFn(cvode_mem, c_funloc(JacFn)) if (ierr /= 0) then - print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' + stop 1 end if ! Start time stepping @@ -333,25 +332,25 @@ program main tout = dtout do outstep = 1, 10 - ! call CVode - ierr = FCVode(cvode_mem, tout, sunvec_u, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVodeEvolve, ierr = ', ierr, '; halting' - stop 1 - end if + ! call CVode + ierr = FCVode(cvode_mem, tout, sunvec_u, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVodeEvolve, ierr = ', ierr, '; halting' + stop 1 + end if - ierr = FCVodeGetNumSteps(cvode_mem, lnst) - if (ierr /= 0) then - print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 - end if + ierr = FCVodeGetNumSteps(cvode_mem, lnst) + if (ierr /= 0) then + print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 + end if - ! print current solution and output statistics - unorm = maxval(abs(u)) - print '(2x,f6.2,2x,es14.6,2x,i5)', tcur, unorm, lnst + ! print current solution and output statistics + unorm = maxval(abs(u)) + print '(2x,f6.2,2x,es14.6,2x,i5)', tcur, unorm, lnst - ! update tout - tout = tout + dtout + ! update tout + tout = tout + dtout end do print *, ' ------------------------------' @@ -399,55 +398,55 @@ subroutine CVodeStats(cvode_mem) ierr = FCVodeGetNumSteps(cvode_mem, nsteps) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumRhsEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumRhsEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumErrTestFails(cvode_mem, netfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumErrTestFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumErrTestFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumNonlinSolvIters(cvode_mem, nniters) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumLinIters(cvode_mem, nliters) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumLinIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumLinConvFails(cvode_mem, ncfl) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumLinConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumNonlinSolvConvFails(cvode_mem, ncf) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function call =',nfe - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num linear solver iters =',nliters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',ncf - print '(4x,A,i9)' ,'Num linear solver fails =',ncfl + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function call =', nfe + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num linear solver iters =', nliters + print '(4x,A,i9)', 'Num nonlinear solver fails =', ncf + print '(4x,A,i9)', 'Num linear solver fails =', ncfl print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_analytic_fp_f2003.f90 b/examples/cvode/F2003_serial/cv_analytic_fp_f2003.f90 index 83c8a46598..3135171b42 100644 --- a/examples/cvode/F2003_serial/cv_analytic_fp_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_analytic_fp_f2003.f90 @@ -51,12 +51,11 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none @@ -77,7 +76,7 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec => FN_VGetArrayPointer(sunvec_f) ! fill RHS vector - fvec(1) = lamda*yvec(1) + 1.0/(1.0+tn*tn) - lamda*atan(tn) + fvec(1) = lamda*yvec(1) + 1.0/(1.0 + tn*tn) - lamda*atan(tn) ! return success ierr = 0 @@ -87,7 +86,6 @@ end function RhsFn end module ode_mod - program main !======= Inclusions =========== @@ -126,11 +124,11 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 10.0d0 - tcur = tstart - tout = tstart - dtout = 1.0d0 - nout = ceiling(tend/dtout) + tend = 10.0d0 + tcur = tstart + tout = tstart + dtout = 1.0d0 + nout = ceiling(tend/dtout) ! initialize solution vector yvec(1) = 0.0d0 @@ -138,22 +136,22 @@ program main ! create SUNDIALS N_Vector sunvec_y => FN_VMake_Serial(neq, yvec, ctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! create CVode memory cvode_mem = FCVodeCreate(CV_ADAMS, ctx) if (.not. c_associated(cvode_mem)) then - print *, 'ERROR: cvode_mem = NULL' - stop 1 + print *, 'ERROR: cvode_mem = NULL' + stop 1 end if ! initialize CVode ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_y) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! set relative and absolute tolerances @@ -162,15 +160,15 @@ program main ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! create fixed point nonlinear solver object sunnls => FSUNNonlinSol_FixedPoint(sunvec_y, 0, ctx) if (.not. associated(sunnls)) then - print *,'ERROR: sunnls = NULL' - stop 1 + print *, 'ERROR: sunnls = NULL' + stop 1 end if ! attache nonlinear solver object to CVode @@ -187,20 +185,20 @@ program main print *, ' t y ' print *, '----------------------------' print '(2x,2(es12.5,1x))', tcur, yvec(1) - do outstep = 1,nout + do outstep = 1, nout - ! call CVode - tout = min(tout + dtout, tend) - ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVODE, ierr = ', ierr, '; halting' - stop 1 - endif + ! call CVode + tout = min(tout + dtout, tend) + ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVODE, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(2x,2(es12.5,1x))', tcur, yvec(1) + ! output current solution + print '(2x,2(es12.5,1x))', tcur, yvec(1) - enddo + end do ! diagnostics output call CVodeStats(cvode_mem) @@ -213,7 +211,6 @@ program main end program main - ! ---------------------------------------------------------------- ! CVodeStats ! @@ -252,33 +249,33 @@ subroutine CVodeStats(cvode_mem) ! general solver statistics ierr = FCVodeGetIntegratorStats(cvode_mem, nsteps, nfevals, nlinsetups, & - netfails, qlast, qcur, hinused, hlast, hcur, tcur) + netfails, qlast, qcur, hinused, hlast, hcur, tcur) if (ierr /= 0) then - print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' + stop 1 end if ! nonlinear solver statistics ierr = FCVodeGetNonlinSolvStats(cvode_mem, nniters, nncfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Last method order =',qlast - print '(4x,A,i9)' ,'Next method order =',qcur - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Last method order =', qlast + print '(4x,A,i9)', 'Next method order =', qcur + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_analytic_sys_dns_f2003.f90 b/examples/cvode/F2003_serial/cv_analytic_sys_dns_f2003.f90 index 9302d65408..541f0433e0 100644 --- a/examples/cvode/F2003_serial/cv_analytic_sys_dns_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_analytic_sys_dns_f2003.f90 @@ -71,7 +71,7 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -83,14 +83,14 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: yvec(:) real(c_double), pointer :: fvec(:) ! ODE system matrix - real(c_double) :: Amat(neq,neq) + real(c_double) :: Amat(neq, neq) !======= Internals ============ @@ -99,11 +99,11 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec => FN_VGetArrayPointer(sunvec_f) ! fill A matrix (column major ordering) - Amat = reshape([& - lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & - lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & - lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0 ], & - [3,3]) + Amat = reshape([ & + lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0], & + [3, 3]) ! fill RHS vector f(t,y) = A*y fvec = matmul(Amat, yvec(1:neq)) @@ -116,7 +116,6 @@ end function RhsFn end module ode_mod - program main !======= Inclusions =========== @@ -144,8 +143,8 @@ program main integer :: outstep ! output loop counter - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: ctx ! SUNDIALS simulation context type(c_ptr) :: cvode_mem ! CVODE memory @@ -157,11 +156,11 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 0.05d0 - tcur = tstart - tout = tstart - dtout = 0.005d0 - nout = ceiling(tend/dtout) + tend = 0.05d0 + tcur = tstart + tout = tstart + dtout = 0.005d0 + nout = ceiling(tend/dtout) ! initialize solution vector yvec(1) = 1.0d0 @@ -174,36 +173,36 @@ program main ! create a serial vector sunvec_y => FN_VMake_Serial(neq, yvec, ctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! create a dense matrix sunmat_A => FSUNDenseMatrix(neq, neq, ctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! create a dense linear solver sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, ctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! create CVode memory cvode_mem = FCVodeCreate(CV_BDF, ctx) if (.not. c_associated(cvode_mem)) then - print *, 'ERROR: cvode_mem = NULL' - stop 1 + print *, 'ERROR: cvode_mem = NULL' + stop 1 end if ! initialize CVode ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_y) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! set relative and absolute tolerances @@ -212,15 +211,15 @@ program main ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! attach linear solver - ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); + ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ! start time stepping @@ -230,20 +229,20 @@ program main print *, ' t y1 y2 y3 ' print *, '------------------------------------------------------' print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - do outstep = 1,nout + do outstep = 1, nout - ! call CVode - tout = min(tout + dtout, tend) - ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVODE, ierr = ', ierr, '; halting' - stop 1 - endif + ! call CVode + tout = min(tout + dtout, tend) + ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVODE, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) + ! output current solution + print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - enddo + end do ! diagnostics output call CVodeStats(cvode_mem) @@ -257,7 +256,6 @@ program main end program main - ! ---------------------------------------------------------------- ! CVodeStats ! @@ -298,41 +296,41 @@ subroutine CVodeStats(cvode_mem) ! general solver statistics ierr = FCVodeGetIntegratorStats(cvode_mem, nsteps, nfevals, nlinsetups, & - netfails, qlast, qcur, hinused, hlast, hcur, tcur) + netfails, qlast, qcur, hinused, hlast, hcur, tcur) if (ierr /= 0) then - print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' + stop 1 end if ! nonlinear solver statistics ierr = FCVodeGetNonlinSolvStats(cvode_mem, nniters, nncfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' + stop 1 end if ! number of Jacobian evaluations ierr = FCVodeGetNumJacEvals(cvode_mem, njevals) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Last method order =',qlast - print '(4x,A,i9)' ,'Next method order =',qcur - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails - print '(4x,A,i9)' ,'Num Jacobian evaluations =',njevals + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Last method order =', qlast + print '(4x,A,i9)', 'Next method order =', qcur + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails + print '(4x,A,i9)', 'Num Jacobian evaluations =', njevals print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_analytic_sys_dns_jac_f2003.f90 b/examples/cvode/F2003_serial/cv_analytic_sys_dns_jac_f2003.f90 index bf79b5bde6..fa55dda7d9 100644 --- a/examples/cvode/F2003_serial/cv_analytic_sys_dns_jac_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_analytic_sys_dns_jac_f2003.f90 @@ -71,12 +71,11 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none @@ -84,14 +83,14 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: yvec(:) real(c_double), pointer :: fvec(:) ! ODE system matrix - real(c_double) :: Amat(neq,neq) + real(c_double) :: Amat(neq, neq) !======= Internals ============ @@ -100,11 +99,11 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec => FN_VGetArrayPointer(sunvec_f) ! fill A matrix (column major ordering) - Amat = reshape([& - lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & - lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & - lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0 ], & - [3,3]) + Amat = reshape([ & + lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0], & + [3, 3]) ! fill RHS vector f(t,y) = A*y fvec = matmul(Amat, yvec(1:neq)) @@ -115,7 +114,6 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & end function RhsFn - ! ---------------------------------------------------------------- ! JacFn: The Jacobian of the ODE hand side function J = df/dy ! @@ -125,15 +123,14 @@ end function RhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & - user_data, tmp1, tmp2, tmp3) & - result(ierr) bind(C,name='JacFn') + user_data, tmp1, tmp2, tmp3) & + result(ierr) bind(C, name='JacFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding use fsunmatrix_dense_mod - !======= Declarations ========= implicit none @@ -154,10 +151,10 @@ integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & Jmat => FSUNDenseMatrix_Data(sunmat_J) ! fill J matrix (column major ordering) - Jmat = & - [lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0,& - lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0,& - lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0] + Jmat = & + [lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0] ! return success ierr = 0 @@ -167,7 +164,6 @@ end function JacFn end module ode_mod - program main !======= Inclusions =========== @@ -197,8 +193,8 @@ program main type(c_ptr) :: ctx ! sundials simulation context type(c_ptr) :: cvode_mem ! CVODE memory - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver ! solution vector, neq is set in the ode_mod module @@ -208,11 +204,11 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 0.05d0 - tcur = tstart - tout = tstart - dtout = 0.005d0 - nout = ceiling(tend/dtout) + tend = 0.05d0 + tcur = tstart + tout = tstart + dtout = 0.005d0 + nout = ceiling(tend/dtout) ! initialize solution vector yvec(1) = 1.0d0 @@ -225,36 +221,36 @@ program main ! create SUNDIALS N_Vector sunvec_y => FN_VMake_Serial(neq, yvec, ctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! create a dense matrix sunmat_A => FSUNDenseMatrix(neq, neq, ctx) if (.not. associated(sunmat_A)) then - print *,'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! create a dense linear solver sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, ctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! create CVode memory cvode_mem = FCVodeCreate(CV_BDF, ctx) if (.not. c_associated(cvode_mem)) then - print *, 'ERROR: cvode_mem = NULL' - stop 1 + print *, 'ERROR: cvode_mem = NULL' + stop 1 end if ! initialize CVode ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_y) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! set relative and absolute tolerances @@ -263,22 +259,22 @@ program main ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! attach linear solver - ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); + ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ! set Jacobian routine ierr = FCVodeSetJacFn(cvode_mem, c_funloc(JacFn)) if (ierr /= 0) then - print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' + stop 1 end if ! start time stepping @@ -288,20 +284,20 @@ program main print *, ' t y1 y2 y3 ' print *, '------------------------------------------------------' print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - do outstep = 1,nout + do outstep = 1, nout - ! call CVode - tout = min(tout + dtout, tend) - ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVODE, ierr = ', ierr, '; halting' - stop 1 - endif + ! call CVode + tout = min(tout + dtout, tend) + ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVODE, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) + ! output current solution + print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - enddo + end do ! diagnostics output call CVodeStats(cvode_mem) @@ -315,7 +311,6 @@ program main end program main - ! ---------------------------------------------------------------- ! CVodeStats ! @@ -356,41 +351,41 @@ subroutine CVodeStats(cvode_mem) ! general solver statistics ierr = FCVodeGetIntegratorStats(cvode_mem, nsteps, nfevals, nlinsetups, & - netfails, qlast, qcur, hinused, hlast, hcur, tcur) + netfails, qlast, qcur, hinused, hlast, hcur, tcur) if (ierr /= 0) then - print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' + stop 1 end if ! nonlinear solver statistics ierr = FCVodeGetNonlinSolvStats(cvode_mem, nniters, nncfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' + stop 1 end if ! number of Jacobian evaluations ierr = FCVodeGetNumJacEvals(cvode_mem, njevals) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Last method order =',qlast - print '(4x,A,i9)' ,'Next method order =',qcur - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails - print '(4x,A,i9)' ,'Num Jacobian evaluations =',njevals + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Last method order =', qlast + print '(4x,A,i9)', 'Next method order =', qcur + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails + print '(4x,A,i9)', 'Num Jacobian evaluations =', njevals print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_analytic_sys_klu_f2003.f90 b/examples/cvode/F2003_serial/cv_analytic_sys_klu_f2003.f90 index f4360ff1c7..33fd2ad507 100644 --- a/examples/cvode/F2003_serial/cv_analytic_sys_klu_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_analytic_sys_klu_f2003.f90 @@ -71,12 +71,11 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none @@ -84,14 +83,14 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: yvec(:) real(c_double), pointer :: fvec(:) ! ODE system matrix - real(c_double) :: Amat(neq,neq) + real(c_double) :: Amat(neq, neq) !======= Internals ============ @@ -100,11 +99,11 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec => FN_VGetArrayPointer(sunvec_f) ! fill A matrix (column major ordering) - Amat = reshape([& - lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & - lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & - lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0 ], & - [3,3]) + Amat = reshape([ & + lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0], & + [3, 3]) ! fill RHS vector f(t,y) = A*y fvec = matmul(Amat, yvec(1:neq)) @@ -124,15 +123,14 @@ end function RhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & - user_data, tmp1, tmp2, tmp3) & - result(ierr) bind(C,name='JacFn') + user_data, tmp1, tmp2, tmp3) & + result(ierr) bind(C, name='JacFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding use fsunmatrix_sparse_mod - !======= Declarations ========= implicit none @@ -147,7 +145,7 @@ integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & ! pointer to data in SUNDIALS matrix integer(c_int64_t), pointer :: Jidxptr(:) integer(c_int64_t), pointer :: Jidxval(:) - real(c_double), pointer :: Jmat(:) + real(c_double), pointer :: Jmat(:) !======= Internals ============ @@ -159,11 +157,10 @@ integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & Jmat => FSUNSparseMatrix_Data(sunmat_J) ! fill J matrix (column major ordering) - Jmat = & - [lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0,& - lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0,& - lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0] - + Jmat = & + [lamda/4.d0 - 23.d0/40.d0, lamda/4.d0 + 21.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 - 3.d0/40.d0, lamda/4.d0 + 1.d0/40, lamda/2.d0 + 1.d0/20.d0, & + lamda/4.d0 + 13.d0/40.d0, lamda/4.d0 - 11.d0/40, lamda/2.d0 - 1.d0/20.d0] Jidxptr = [0, 3, 6, 9] Jidxval = [0, 1, 2, 0, 1, 2, 0, 1, 2] @@ -176,7 +173,6 @@ end function JacFn end module ode_mod - program main !======= Inclusions =========== @@ -205,8 +201,8 @@ program main integer :: outstep ! output loop counter - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: cvode_mem ! CVODE memory @@ -218,11 +214,11 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 0.05d0 - tcur = tstart - tout = tstart - dtout = 0.005d0 - nout = ceiling(tend/dtout) + tend = 0.05d0 + tcur = tstart + tout = tstart + dtout = 0.005d0 + nout = ceiling(tend/dtout) ! initialize solution vector yvec(1) = 1.0d0 @@ -231,43 +227,43 @@ program main ierr = FSUNContext_Create(SUN_COMM_NULL, sunctx) if (ierr /= 0) then - print *, 'ERROR: FSUNContext_Create returned non-zero' - stop 1 + print *, 'ERROR: FSUNContext_Create returned non-zero' + stop 1 end if ! create a serial vector sunvec_y => FN_VMake_Serial(neq, yvec, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! create a sparse matrix sunmat_A => FSUNSparseMatrix(neq, neq, neq*neq, CSC_MAT, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! create a klu linear solver sunlinsol_LS => FSUNLinSol_KLU(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! create CVode memory cvode_mem = FCVodeCreate(CV_BDF, sunctx) if (.not. c_associated(cvode_mem)) then - print *, 'ERROR: cvode_mem = NULL' - stop 1 + print *, 'ERROR: cvode_mem = NULL' + stop 1 end if ! initialize CVode ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_y) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! set relative and absolute tolerances @@ -276,22 +272,22 @@ program main ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! attach linear solver ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A) if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ! set Jacobian routine ierr = FCVodeSetJacFn(cvode_mem, c_funloc(JacFn)) if (ierr /= 0) then - print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' + stop 1 end if ! start time stepping @@ -301,20 +297,20 @@ program main print *, ' t y1 y2 y3 ' print *, '------------------------------------------------------' print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - do outstep = 1,nout + do outstep = 1, nout - ! call CVode - tout = min(tout + dtout, tend) - ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVODE, ierr = ', ierr, '; halting' - stop 1 - endif + ! call CVode + tout = min(tout + dtout, tend) + ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVODE, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) + ! output current solution + print '(2x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - enddo + end do ! diagnostics output call CVodeStats(cvode_mem) @@ -328,7 +324,6 @@ program main end program main - ! ---------------------------------------------------------------- ! CVodeStats ! @@ -369,41 +364,41 @@ subroutine CVodeStats(cvode_mem) ! general solver statistics ierr = FCVodeGetIntegratorStats(cvode_mem, nsteps, nfevals, nlinsetups, & - netfails, qlast, qcur, hinused, hlast, hcur, tcur) + netfails, qlast, qcur, hinused, hlast, hcur, tcur) if (ierr /= 0) then - print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' + stop 1 end if ! nonlinear solver statistics ierr = FCVodeGetNonlinSolvStats(cvode_mem, nniters, nncfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' + stop 1 end if ! number of Jacobian evaluations ierr = FCVodeGetNumJacEvals(cvode_mem, njevals) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Last method order =',qlast - print '(4x,A,i9)' ,'Next method order =',qcur - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails - print '(4x,A,i9)' ,'Num Jacobian evaluations =',njevals + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Last method order =', qlast + print '(4x,A,i9)', 'Next method order =', qcur + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails + print '(4x,A,i9)', 'Num Jacobian evaluations =', njevals print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_brusselator_dns_f2003.f90 b/examples/cvode/F2003_serial/cv_brusselator_dns_f2003.f90 index 33ef0b610c..6bf52b7901 100644 --- a/examples/cvode/F2003_serial/cv_brusselator_dns_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_brusselator_dns_f2003.f90 @@ -41,8 +41,8 @@ module ode_mod integer(c_int64_t), parameter :: neq = 3 ! ODE parameters - double precision, parameter :: a = 1.2d0 - double precision, parameter :: b = 2.5d0 + double precision, parameter :: a = 1.2d0 + double precision, parameter :: b = 2.5d0 double precision, parameter :: ep = 1.0d-5 contains @@ -57,12 +57,11 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none @@ -70,7 +69,7 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: yvec(:) @@ -83,9 +82,9 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec => FN_VGetArrayPointer(sunvec_f) ! fill RHS vector - fvec(1) = a - (yvec(3) + 1.0d0) * yvec(1) + yvec(2) * yvec(1) * yvec(1) - fvec(2) = yvec(3) * yvec(1) - yvec(2) * yvec(1) * yvec(1) - fvec(3) = (b-yvec(3))/ep - yvec(3) * yvec(1) + fvec(1) = a - (yvec(3) + 1.0d0)*yvec(1) + yvec(2)*yvec(1)*yvec(1) + fvec(2) = yvec(3)*yvec(1) - yvec(2)*yvec(1)*yvec(1) + fvec(3) = (b - yvec(3))/ep - yvec(3)*yvec(1) ! return success ierr = 0 @@ -102,15 +101,14 @@ end function RhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & - user_data, tmp1, tmp2, tmp3) & - result(ierr) bind(C,name='JacFn') + user_data, tmp1, tmp2, tmp3) & + result(ierr) bind(C, name='JacFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding use fsunmatrix_dense_mod - !======= Declarations ========= implicit none @@ -137,9 +135,9 @@ integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, & Jmat => FSUNDenseMatrix_Data(sunmat_J) ! fill Jacobian matrix - Jmat = [-(yvec(3)+1.0d0) + 2.0d0*yvec(1)*yvec(2),& - yvec(3) - 2.0d0*yvec(1)*yvec(2), -yvec(3),& - yvec(1)*yvec(1), -yvec(1)*yvec(1), 0.0d0,& + Jmat = [-(yvec(3) + 1.0d0) + 2.0d0*yvec(1)*yvec(2), & + yvec(3) - 2.0d0*yvec(1)*yvec(2), -yvec(3), & + yvec(1)*yvec(1), -yvec(1)*yvec(1), 0.0d0, & -yvec(1), yvec(1), -1.0d0/ep - yvec(1)] ! return success @@ -150,7 +148,6 @@ end function JacFn end module ode_mod - program main !======= Inclusions =========== @@ -165,7 +162,7 @@ program main !======= Declarations ========= implicit none - ! local variables + ! local variables real(c_double) :: tstart ! initial time real(c_double) :: tend ! final time real(c_double) :: rtol, atol ! relative and absolute tolerance @@ -180,8 +177,8 @@ program main type(c_ptr) :: ctx ! SUNDIALS context type(c_ptr) :: cvode_mem ! CVODE memory - type(N_Vector), pointer :: sunvec_y ! sundials vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver ! solution vector, neq is set in the ode_mod module @@ -191,11 +188,11 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 10.0d0 - tcur = tstart - tout = tstart - dtout = (tend-tstart)/10.d0 - nout = ceiling(tend/dtout) + tend = 10.0d0 + tcur = tstart + tout = tstart + dtout = (tend - tstart)/10.d0 + nout = ceiling(tend/dtout) ! initialize solution vector yvec(1) = 3.9d0 @@ -208,36 +205,36 @@ program main ! create SUNDIALS N_Vector sunvec_y => FN_VMake_Serial(neq, yvec, ctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! create a dense matrix sunmat_A => FSUNDenseMatrix(neq, neq, ctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! create a dense linear solver sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, ctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! create CVode memory cvode_mem = FCVodeCreate(CV_BDF, ctx) if (.not. c_associated(cvode_mem)) then - print *, 'ERROR: cvode_mem = NULL' - stop 1 + print *, 'ERROR: cvode_mem = NULL' + stop 1 end if ! initialize CVode ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_y) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! set relative and absolute tolerances @@ -246,22 +243,22 @@ program main ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! attach linear solver - ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); + ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ! set Jacobian routine ierr = FCVodeSetJacFn(cvode_mem, c_funloc(JacFn)) if (ierr /= 0) then - print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting' + stop 1 end if ! start time stepping @@ -271,20 +268,20 @@ program main print *, ' t u v w' print *, '----------------------------------------------------' print '(1x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - do outstep = 1,nout + do outstep = 1, nout - ! call CVode - tout = min(tout + dtout, tend) - ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVODE, ierr = ', ierr, '; halting' - stop 1 - endif + ! call CVode + tout = min(tout + dtout, tend) + ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVODE, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(1x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) + ! output current solution + print '(1x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3) - enddo + end do ! diagnostics output call CVodeStats(cvode_mem) @@ -298,7 +295,6 @@ program main end program Main - ! ---------------------------------------------------------------- ! CVodeStats ! @@ -339,41 +335,41 @@ subroutine CVodeStats(cvode_mem) ! general solver statistics ierr = FCVodeGetIntegratorStats(cvode_mem, nsteps, nfevals, nlinsetups, & - netfails, qlast, qcur, hinused, hlast, hcur, tcur) + netfails, qlast, qcur, hinused, hlast, hcur, tcur) if (ierr /= 0) then - print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' + stop 1 end if ! nonlinear solver statistics ierr = FCVodeGetNonlinSolvStats(cvode_mem, nniters, nncfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' + stop 1 end if ! nonlinear solver statistics ierr = FCVodeGetNumJacEvals(cvode_mem, njevals) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Last method order =',qlast - print '(4x,A,i9)' ,'Next method order =',qcur - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails - print '(4x,A,i9)' ,'Num Jacobian evaluations =',njevals + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Last method order =', qlast + print '(4x,A,i9)', 'Next method order =', qcur + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails + print '(4x,A,i9)', 'Num Jacobian evaluations =', njevals print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_diurnal_kry_bp_f2003.f90 b/examples/cvode/F2003_serial/cv_diurnal_kry_bp_f2003.f90 index fe69831f05..cc543fdab2 100644 --- a/examples/cvode/F2003_serial/cv_diurnal_kry_bp_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_diurnal_kry_bp_f2003.f90 @@ -77,7 +77,7 @@ module diurnal_bp_mod real(c_double), parameter :: a4 = 7.601d0 ! Solving assistance fixed parameters - real(c_double), parameter :: twohr = 7200.0D0 + real(c_double), parameter :: twohr = 7200.0d0 real(c_double), parameter :: rtol = 1.0d-5 real(c_double), parameter :: floor = 100.0d0 real(c_double), parameter :: delt = 0.0d0 @@ -108,7 +108,7 @@ module diurnal_bp_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -120,7 +120,7 @@ integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local data integer(c_int) :: jleft, jright, jup, jdn @@ -130,69 +130,69 @@ integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & real(c_double) :: vertd1, vertd2, ydn, yup ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(2,mx,my) :: uvecI(:,:,:) - real(c_double), pointer, dimension(2,mx,my) :: fvecI(:,:,:) + real(c_double), pointer, dimension(2, mx, my) :: uvecI(:, :, :) + real(c_double), pointer, dimension(2, mx, my) :: fvecI(:, :, :) !======= Internals ============ ! get data arrays from SUNDIALS vectors - uvecI(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) - fvecI(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_f) + uvecI(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) + fvecI(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_f) ! Set diurnal rate coefficients. - s = sin(om * tn) + s = sin(om*tn) if (s > 0.0d0) then - q3 = exp(-a3 / s) - q4 = exp(-a4 / s) + q3 = exp(-a3/s) + q4 = exp(-a4/s) else - q3 = 0.0d0 - q4 = 0.0d0 + q3 = 0.0d0 + q4 = 0.0d0 end if ! Loop over all grid points. do jy = 1, my - ydn = 30.0d0 + (jy - 1.5d0) * dy - yup = ydn + dy - cydn = vdco * exp(0.2d0 * ydn) - cyup = vdco * exp(0.2d0 * yup) - jdn = jy-1 - if (jy == 1) jdn = my - jup = jy+1 - if (jy == my) jup = 1 - do jx = 1, mx - c1 = uvecI(1,jx,jy) - c2 = uvecI(2,jx,jy) - ! Set kinetic rate terms. - qq1 = q1 * c1 * c3 - qq2 = q2 * c1 * c2 - qq3 = q3 * c3 - qq4 = q4 * c2 - rkin1 = -qq1 - qq2 + 2.0d0 * qq3 + qq4 - rkin2 = qq1 - qq2 - qq4 - ! Set vertical diffusion terms. - c1dn = uvecI(1,jx,jdn) - c2dn = uvecI(2,jx,jdn) - c1up = uvecI(1,jx,jup) - c2up = uvecI(2,jx,jup) - vertd1 = cyup * (c1up - c1) - cydn * (c1 - c1dn) - vertd2 = cyup * (c2up - c2) - cydn * (c2 - c2dn) - ! Set horizontal diffusion and advection terms. - jleft = jx-1 - if (jx == 1) jleft = mx - jright = jx+1 - if (jx == mx) jright = 1 - c1lt = uvecI(1,jleft,jy) - c2lt = uvecI(2,jleft,jy) - c1rt = uvecI(1,jright,jy) - c2rt = uvecI(2,jright,jy) - hord1 = hdco * (c1rt - 2.0d0 * c1 + c1lt) - hord2 = hdco * (c2rt - 2.0d0 * c2 + c2lt) - horad1 = haco * (c1rt - c1lt) - horad2 = haco * (c2rt - c2lt) - ! load all terms into fvecI. - fvecI(1,jx,jy) = vertd1 + hord1 + horad1 + rkin1 - fvecI(2,jx,jy) = vertd2 + hord2 + horad2 + rkin2 - end do + ydn = 30.0d0 + (jy - 1.5d0)*dy + yup = ydn + dy + cydn = vdco*exp(0.2d0*ydn) + cyup = vdco*exp(0.2d0*yup) + jdn = jy - 1 + if (jy == 1) jdn = my + jup = jy + 1 + if (jy == my) jup = 1 + do jx = 1, mx + c1 = uvecI(1, jx, jy) + c2 = uvecI(2, jx, jy) + ! Set kinetic rate terms. + qq1 = q1*c1*c3 + qq2 = q2*c1*c2 + qq3 = q3*c3 + qq4 = q4*c2 + rkin1 = -qq1 - qq2 + 2.0d0*qq3 + qq4 + rkin2 = qq1 - qq2 - qq4 + ! Set vertical diffusion terms. + c1dn = uvecI(1, jx, jdn) + c2dn = uvecI(2, jx, jdn) + c1up = uvecI(1, jx, jup) + c2up = uvecI(2, jx, jup) + vertd1 = cyup*(c1up - c1) - cydn*(c1 - c1dn) + vertd2 = cyup*(c2up - c2) - cydn*(c2 - c2dn) + ! Set horizontal diffusion and advection terms. + jleft = jx - 1 + if (jx == 1) jleft = mx + jright = jx + 1 + if (jx == mx) jright = 1 + c1lt = uvecI(1, jleft, jy) + c2lt = uvecI(2, jleft, jy) + c1rt = uvecI(1, jright, jy) + c2rt = uvecI(2, jright, jy) + hord1 = hdco*(c1rt - 2.0d0*c1 + c1lt) + hord2 = hdco*(c2rt - 2.0d0*c2 + c2lt) + horad1 = haco*(c1rt - c1lt) + horad2 = haco*(c2rt - c2lt) + ! load all terms into fvecI. + fvecI(1, jx, jy) = vertd1 + hord1 + horad1 + rkin1 + fvecI(2, jx, jy) = vertd2 + hord2 + horad2 + rkin2 + end do end do ! return success @@ -205,7 +205,6 @@ end function RhsFn end module diurnal_bp_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -230,12 +229,12 @@ program main integer(c_int64_t) :: mu, ml ! band preconditioner constants real(c_double) :: x, y ! initialization index variables - type(N_Vector), pointer :: sunvec_u ! sundials vector - type(N_Vector), pointer :: sunvec_f ! sundials vector + type(N_Vector), pointer :: sunvec_u ! sundials vector + type(N_Vector), pointer :: sunvec_f ! sundials vector type(SUNLinearSolver), pointer :: sunls ! sundials linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) type(c_ptr) :: cvode_mem ! CVODE memory - real(c_double), pointer, dimension(2,mx,my) :: uvec(:,:,:) ! underlying vector + real(c_double), pointer, dimension(2, mx, my) :: uvec(:, :, :) ! underlying vector ! output statistic variables integer(c_long) :: lnst(1) @@ -248,86 +247,86 @@ program main ! initialize ODE tstart = 0.0d0 - tcur = tstart + tcur = tstart ! create SUNDIALS N_Vector sunvec_u => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_f => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_f)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - uvec(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) + uvec(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) ! initialize and fill initial condition vector - do jy = 1,my - y = 30.0d0 + (jy - 1.0d0) * dy - cy = (0.1d0 * (y - 40.0d0))**2 - cy = 1.0d0 - cy + 0.5d0 * cy**2 - do jx = 1,mx - x = (jx - 1.0d0) * dx - cx = (0.1d0 * (x - 10.0d0))**2 - cx = 1.0d0 - cx + 0.5d0 * cx**2 - uvec(1,jx,jy) = 1.0d6 * cx * cy - uvec(2,jx,jy) = 1.0d12 * cx * cy - end do + do jy = 1, my + y = 30.0d0 + (jy - 1.0d0)*dy + cy = (0.1d0*(y - 40.0d0))**2 + cy = 1.0d0 - cy + 0.5d0*cy**2 + do jx = 1, mx + x = (jx - 1.0d0)*dx + cx = (0.1d0*(x - 10.0d0))**2 + cx = 1.0d0 - cx + 0.5d0*cx**2 + uvec(1, jx, jy) = 1.0d6*cx*cy + uvec(2, jx, jy) = 1.0d12*cx*cy + end do end do ! create and initialize CVode memory cvode_mem = FCVodeCreate(CV_BDF, ctx) - if (.not. c_associated(cvode_mem)) print *,'ERROR: cvode_mem = NULL' + if (.not. c_associated(cvode_mem)) print *, 'ERROR: cvode_mem = NULL' ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_u) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! Tell CVODE to use a SPGMR linear solver. sunls => FSUNLinSol_SPGMR(sunvec_u, Jpretype, maxL, ctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - stop 1 + print *, 'ERROR: sunls = NULL' + stop 1 end if ! Attach the linear solver (with NULL SUNMatrix object) sunmat_A => null() ierr = FCVodeSetLinearSolver(cvode_mem, sunls, sunmat_A) if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ierr = FSUNLinSol_SPGMRSetGSType(sunls, iGStype) if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver' - stop 1 + print *, 'Error in FCVodeSetLinearSolver' + stop 1 end if ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeSetMaxNumSteps(cvode_mem, mxsteps) if (ierr /= 0) then - print *, 'Error in FCVodeSetMaxNumSteps' - stop 1 + print *, 'Error in FCVodeSetMaxNumSteps' + stop 1 end if mu = 2 ml = 2 ierr = FCVBandPrecInit(cvode_mem, neq, mu, ml) if (ierr /= 0) then - print *, 'Error in FCVBandPrecInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVBandPrecInit, ierr = ', ierr, '; halting' + stop 1 end if ! Start time stepping @@ -338,33 +337,33 @@ program main print *, ' t c2 (bottom left middle top right) | lnst lh' print *, ' -----------------------------------------------------------------------------------' tout = twohr - do outstep = 1,12 - - ! call CVode - ierr = FCVode(cvode_mem, tout, sunvec_u, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVodeEvolve, ierr = ', ierr, '; halting' - stop 1 - end if - - ierr = FCVodeGetNumSteps(cvode_mem, lnst) - if (ierr /= 0) then - print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 - end if - - ierr = FCVodeGetCurrentStep(cvode_mem, lh) - if (ierr /= 0) then - print *, 'Error in FCVodeGetCurrentStep, ierr = ', ierr, '; halting' - stop 1 - end if - - ! print current solution and output statistics - print '(2x,4(es14.6,2x),i5,es14.6)', tcur, uvec(1,1,1), uvec(1,5,5), uvec(1,10,10), lnst, lh - print '(18x,3(es14.6,2x))', uvec(2,1,1), uvec(2,5,5), uvec(2,10,10) - - ! update tout - tout = tout + twohr + do outstep = 1, 12 + + ! call CVode + ierr = FCVode(cvode_mem, tout, sunvec_u, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVodeEvolve, ierr = ', ierr, '; halting' + stop 1 + end if + + ierr = FCVodeGetNumSteps(cvode_mem, lnst) + if (ierr /= 0) then + print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 + end if + + ierr = FCVodeGetCurrentStep(cvode_mem, lh) + if (ierr /= 0) then + print *, 'Error in FCVodeGetCurrentStep, ierr = ', ierr, '; halting' + stop 1 + end if + + ! print current solution and output statistics + print '(2x,4(es14.6,2x),i5,es14.6)', tcur, uvec(1, 1, 1), uvec(1, 5, 5), uvec(1, 10, 10), lnst, lh + print '(18x,3(es14.6,2x))', uvec(2, 1, 1), uvec(2, 5, 5), uvec(2, 10, 10) + + ! update tout + tout = tout + twohr end do print *, ' -----------------------------------------------------------------------------------' @@ -421,100 +420,100 @@ subroutine CVodeStats(cvode_mem) ierr = FCVodeGetNumSteps(cvode_mem, nsteps) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumRhsEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumRhsEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumErrTestFails(cvode_mem, netfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumErrTestFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumErrTestFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumPrecEvals(cvode_mem, npe) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumPrecEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumPrecEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumPrecSolves(cvode_mem, nps) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumPrecSolves, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumPrecSolves, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumNonlinSolvIters(cvode_mem, nniters) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumLinIters(cvode_mem, nliters) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumLinIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinIters, ierr = ', ierr, '; halting' + stop 1 end if avdim = dble(nliters)/dble(nniters) ierr = FCVodeGetNumLinConvFails(cvode_mem, ncfl) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumLinConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumNonlinSolvConvFails(cvode_mem, ncf) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetWorkSpace(cvode_mem, lenrw, leniw) if (ierr /= 0) then - print *, 'Error in FCVodeGetWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetLinWorkSpace(cvode_mem, lenrwls, leniwls) if (ierr /= 0) then - print *, 'Error in FCVodeGetLinWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetLinWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVBandPrecGetWorkSpace(cvode_mem, lenrwbp, leniwbp) if (ierr /= 0) then - print *, 'Error in FCVBandPrecGetWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVBandPrecGetWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVBandPrecGetNumRhsEvals(cvode_mem, nfebp) if (ierr /= 0) then - print *, 'Error in FCVBandPrecGetNumRhsEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVBandPrecGetNumRhsEvals, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function call =',nfe - print '(4x,A,i9)' ,'Total num preconditioner evals =',npe - print '(4x,A,i9)' ,'Total num preconditioner solves =',nps - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num linear solver iters =',nliters - print '(4x,A,es14.6)' ,'Avg Krylov subspace dim =',avdim - print '(4x,A,i9)' ,'Num nonlinear solver fails =',ncf - print '(4x,A,i9)' ,'Num linear solver fails =',ncfl - print '(4x,A,2(i9,3x))' ,'main solver real/int workspace sizes =',lenrw,leniw - print '(4x,A,2(i9,3x))' ,'linear solver real/int workspace sizes =',lenrwls,leniwls - print '(4x,A,2(i9,3x))' ,'CVBandPre real/int workspace sizes =',lenrwbp,leniwbp - print '(4x,A,i9)' ,'CVBandPre number of f evaluations =',nfebp + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function call =', nfe + print '(4x,A,i9)', 'Total num preconditioner evals =', npe + print '(4x,A,i9)', 'Total num preconditioner solves =', nps + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num linear solver iters =', nliters + print '(4x,A,es14.6)', 'Avg Krylov subspace dim =', avdim + print '(4x,A,i9)', 'Num nonlinear solver fails =', ncf + print '(4x,A,i9)', 'Num linear solver fails =', ncfl + print '(4x,A,2(i9,3x))', 'main solver real/int workspace sizes =', lenrw, leniw + print '(4x,A,2(i9,3x))', 'linear solver real/int workspace sizes =', lenrwls, leniwls + print '(4x,A,2(i9,3x))', 'CVBandPre real/int workspace sizes =', lenrwbp, leniwbp + print '(4x,A,i9)', 'CVBandPre number of f evaluations =', nfebp print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_diurnal_kry_f2003.f90 b/examples/cvode/F2003_serial/cv_diurnal_kry_f2003.f90 index d087b60d99..0dbd71e32c 100644 --- a/examples/cvode/F2003_serial/cv_diurnal_kry_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_diurnal_kry_f2003.f90 @@ -77,7 +77,7 @@ module diurnal_mod real(c_double), parameter :: a4 = 7.601d0 ! Solving assistance fixed parameters - real(c_double), parameter :: twohr = 7200.0D0 + real(c_double), parameter :: twohr = 7200.0d0 real(c_double), parameter :: rtol = 1.0d-5 real(c_double), parameter :: floor = 100.0d0 real(c_double), parameter :: delt = 0.0d0 @@ -86,7 +86,7 @@ module diurnal_mod integer(c_int), parameter :: iGStype = 1 integer(c_int), parameter :: maxL = 0 integer(c_long), parameter :: mxsteps = 1000 - real(c_double) :: p_p(2,2,mx,my) + real(c_double) :: p_p(2, 2, mx, my) ! ODE non-constant parameters real(c_double) :: q3 @@ -108,7 +108,7 @@ module diurnal_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -120,7 +120,7 @@ integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! local data integer(c_int) :: jleft, jright, jup, jdn @@ -130,69 +130,69 @@ integer(c_int) function RhsFn(tn, sunvec_u, sunvec_f, user_data) & real(c_double) :: vertd1, vertd2, ydn, yup ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(2,mx,my) :: uvec(:,:,:) - real(c_double), pointer, dimension(2,mx,my) :: fvec(:,:,:) + real(c_double), pointer, dimension(2, mx, my) :: uvec(:, :, :) + real(c_double), pointer, dimension(2, mx, my) :: fvec(:, :, :) !======= Internals ============ ! get data arrays from SUNDIALS vectors - uvec(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) - fvec(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_f) + uvec(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) + fvec(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_f) ! Set diurnal rate coefficients. - s = sin(om * tn) + s = sin(om*tn) if (s > 0.0d0) then - q3 = exp(-a3 / s) - q4 = exp(-a4 / s) + q3 = exp(-a3/s) + q4 = exp(-a4/s) else - q3 = 0.0d0 - q4 = 0.0d0 + q3 = 0.0d0 + q4 = 0.0d0 end if ! Loop over all grid points. do jy = 1, my - ydn = 30.0d0 + (jy - 1.5d0) * dy - yup = ydn + dy - cydn = vdco * exp(0.2d0 * ydn) - cyup = vdco * exp(0.2d0 * yup) - jdn = jy-1 - if (jy == 1) jdn = my - jup = jy+1 - if (jy == my) jup = 1 - do jx = 1, mx - c1 = uvec(1,jx,jy) - c2 = uvec(2,jx,jy) - ! Set kinetic rate terms. - qq1 = q1 * c1 * c3 - qq2 = q2 * c1 * c2 - qq3 = q3 * c3 - qq4 = q4 * c2 - rkin1 = -qq1 - qq2 + 2.0d0 * qq3 + qq4 - rkin2 = qq1 - qq2 - qq4 - ! Set vertical diffusion terms. - c1dn = uvec(1,jx,jdn) - c2dn = uvec(2,jx,jdn) - c1up = uvec(1,jx,jup) - c2up = uvec(2,jx,jup) - vertd1 = cyup * (c1up - c1) - cydn * (c1 - c1dn) - vertd2 = cyup * (c2up - c2) - cydn * (c2 - c2dn) - ! Set horizontal diffusion and advection terms. - jleft = jx-1 - if (jx == 1) jleft = mx - jright = jx+1 - if (jx == mx) jright = 1 - c1lt = uvec(1,jleft,jy) - c2lt = uvec(2,jleft,jy) - c1rt = uvec(1,jright,jy) - c2rt = uvec(2,jright,jy) - hord1 = hdco * (c1rt - 2.0d0 * c1 + c1lt) - hord2 = hdco * (c2rt - 2.0d0 * c2 + c2lt) - horad1 = haco * (c1rt - c1lt) - horad2 = haco * (c2rt - c2lt) - ! load all terms into fvec. - fvec(1,jx,jy) = vertd1 + hord1 + horad1 + rkin1 - fvec(2,jx,jy) = vertd2 + hord2 + horad2 + rkin2 - end do + ydn = 30.0d0 + (jy - 1.5d0)*dy + yup = ydn + dy + cydn = vdco*exp(0.2d0*ydn) + cyup = vdco*exp(0.2d0*yup) + jdn = jy - 1 + if (jy == 1) jdn = my + jup = jy + 1 + if (jy == my) jup = 1 + do jx = 1, mx + c1 = uvec(1, jx, jy) + c2 = uvec(2, jx, jy) + ! Set kinetic rate terms. + qq1 = q1*c1*c3 + qq2 = q2*c1*c2 + qq3 = q3*c3 + qq4 = q4*c2 + rkin1 = -qq1 - qq2 + 2.0d0*qq3 + qq4 + rkin2 = qq1 - qq2 - qq4 + ! Set vertical diffusion terms. + c1dn = uvec(1, jx, jdn) + c2dn = uvec(2, jx, jdn) + c1up = uvec(1, jx, jup) + c2up = uvec(2, jx, jup) + vertd1 = cyup*(c1up - c1) - cydn*(c1 - c1dn) + vertd2 = cyup*(c2up - c2) - cydn*(c2 - c2dn) + ! Set horizontal diffusion and advection terms. + jleft = jx - 1 + if (jx == 1) jleft = mx + jright = jx + 1 + if (jx == mx) jright = 1 + c1lt = uvec(1, jleft, jy) + c2lt = uvec(2, jleft, jy) + c1rt = uvec(1, jright, jy) + c2rt = uvec(2, jright, jy) + hord1 = hdco*(c1rt - 2.0d0*c1 + c1lt) + hord2 = hdco*(c2rt - 2.0d0*c2 + c2lt) + horad1 = haco*(c1rt - c1lt) + horad2 = haco*(c2rt - c2lt) + ! load all terms into fvec. + fvec(1, jx, jy) = vertd1 + hord1 + horad1 + rkin1 + fvec(2, jx, jy) = vertd2 + hord2 + horad2 + rkin2 + end do end do ! return success @@ -213,7 +213,7 @@ end function RhsFn ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PreSet(t, sunvec_u, sunvec_f, jok, jcur, gamma, user_data) & - result(ierr) bind(C,name='PreSet') + result(ierr) bind(C, name='PreSet') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -228,30 +228,30 @@ integer(c_int) function PreSet(t, sunvec_u, sunvec_f, jok, jcur, gamma, user_dat integer(c_int), value :: jok integer(c_int) :: jcur real(c_double), value :: gamma - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data ! temporary variables - real(c_double), pointer, dimension(2,mx,my) :: u(:,:,:) - real(c_double) :: p_bd(2,2,mx,my) - u(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) + real(c_double), pointer, dimension(2, mx, my) :: u(:, :, :) + real(c_double) :: p_bd(2, 2, mx, my) + u(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) ! initialize return value to success ierr = 0 ! if needed, recompute bd if (jok == 1) then - ! jok = 1. reuse saved bd - jcur = 0 + ! jok = 1. reuse saved bd + jcur = 0 else - ! jok = 0. compute diagonal jacobian blocks. - ! (using q4 value computed on last fcvfun call). - call Prec_Jac(mx, my, u, p_bd, q1, q2, q3, q4, & - c3, dy, hdco, vdco, ierr) - jcur = 1 - endif + ! jok = 0. compute diagonal jacobian blocks. + ! (using q4 value computed on last fcvfun call). + call Prec_Jac(mx, my, u, p_bd, q1, q2, q3, q4, & + c3, dy, hdco, vdco, ierr) + jcur = 1 + end if ! copy bd to p and scale by -gamma - p_p = -gamma * p_bd + p_p = -gamma*p_bd ! Perform LU decomposition call Prec_LU(mm, p_p, ierr) @@ -274,7 +274,7 @@ end function PreSet ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PreSolve(t, sunvec_u, sunvec_f, sunvec_r, sunvec_z, & - gamma, delta, lr, user_data) result(ierr) bind(C,name='PreSolve') + gamma, delta, lr, user_data) result(ierr) bind(C, name='PreSolve') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -290,12 +290,12 @@ integer(c_int) function PreSolve(t, sunvec_u, sunvec_f, sunvec_r, sunvec_z, & type(N_Vector) :: sunvec_z ! output N_Vector real(c_double) :: gamma, delta integer(c_int) :: lr - type(c_ptr), value :: user_data + type(c_ptr), value :: user_data ! temporary variables - real(c_double), pointer, dimension(2,mx,my) :: z(:,:,:), r(:,:,:) - z(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_z) - r(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_r) + real(c_double), pointer, dimension(2, mx, my) :: z(:, :, :), r(:, :, :) + z(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_z) + r(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_r) ! copy rhs into z z = r @@ -323,13 +323,13 @@ end function PreSolve ! -1 = non-recoverable error ! ---------------------------------------------------------------- subroutine Prec_Jac(mmx, mmy, u, bd, qq1, qq2, qq3, qq4, cc3, & - ddy, hhdco, vvdco, ierr) + ddy, hhdco, vvdco, ierr) implicit none integer(c_int), intent(in) :: mmx, mmy - real(c_double), intent(in) :: u(2,mmx,mmy) - real(c_double), intent(out) :: bd(2,2,mmx,mmy) + real(c_double), intent(in) :: u(2, mmx, mmy) + real(c_double), intent(out) :: bd(2, 2, mmx, mmy) real(c_double), intent(in) :: qq1, qq2, qq3, qq4, cc3, ddy, hhdco, vvdco integer(c_int), intent(out) :: ierr @@ -337,19 +337,19 @@ subroutine Prec_Jac(mmx, mmy, u, bd, qq1, qq2, qq3, qq4, cc3, & real(c_double) :: cydn, cyup, diag, ydn, yup do jy = 1, mmy - ydn = 30.0d0 + (jy - 1.5d0) * ddy - yup = ydn + ddy - cydn = vvdco * exp(0.2d0 * ydn) - cyup = vvdco * exp(0.2d0 * yup) - diag = -(cydn + cyup + 2.0d0 * hhdco) - do jx = 1, mmx - c1 = u(1,jx,jy) - c2 = u(2,jx,jy) - bd(1,1,jx,jy) = (-qq1 * cc3 - qq2 * c2) + diag - bd(1,2,jx,jy) = -qq2 * c1 + qq4 - bd(2,1,jx,jy) = qq1 * cc3 - qq2 * c2 - bd(2,2,jx,jy) = (-qq2 * c1 - qq4) + diag - end do + ydn = 30.0d0 + (jy - 1.5d0)*ddy + yup = ydn + ddy + cydn = vvdco*exp(0.2d0*ydn) + cyup = vvdco*exp(0.2d0*yup) + diag = -(cydn + cyup + 2.0d0*hhdco) + do jx = 1, mmx + c1 = u(1, jx, jy) + c2 = u(2, jx, jy) + bd(1, 1, jx, jy) = (-qq1*cc3 - qq2*c2) + diag + bd(1, 2, jx, jy) = -qq2*c1 + qq4 + bd(2, 1, jx, jy) = qq1*cc3 - qq2*c2 + bd(2, 2, jx, jy) = (-qq2*c1 - qq4) + diag + end do end do ! return success @@ -376,7 +376,7 @@ subroutine Prec_LU(mmm, p, ierr) integer(c_int), intent(out) :: ierr integer(c_int64_t), intent(in) :: mmm - real(c_double), intent(inout) :: p(2,2,mmm) + real(c_double), intent(inout) :: p(2, 2, mmm) ! local variable integer(c_int64_t) :: i @@ -386,18 +386,18 @@ subroutine Prec_LU(mmm, p, ierr) ierr = 0 ! add identity matrix and do lu decompositions on blocks, in place. - do i = 1,mmm - p11 = p(1,1,i) + 1.0d0 - p22 = p(2,2,i) + 1.0d0 - p12 = p(1,2,i) - p21 = p(1,2,i) - det = p11*p22 - p12*p21 - if (det == 0.d0) return - - p(1,1,i) = p22/det - p(2,2,i) = p11/det - p(1,2,i) = -p21/det - p(2,1,i) = -p12/det + do i = 1, mmm + p11 = p(1, 1, i) + 1.0d0 + p22 = p(2, 2, i) + 1.0d0 + p12 = p(1, 2, i) + p21 = p(1, 2, i) + det = p11*p22 - p12*p21 + if (det == 0.d0) return + + p(1, 1, i) = p22/det + p(2, 2, i) = p11/det + p(1, 2, i) = -p21/det + p(2, 1, i) = -p12/det end do return @@ -417,26 +417,25 @@ end subroutine Prec_LU ! 1 = recoverable error, ! -1 = non-recoverable error ! ---------------------------------------------------------------- - subroutine Prec_Sol(mx,my, p, z) + subroutine Prec_Sol(mx, my, p, z) implicit none integer(c_int), intent(in) :: mx, my - real(c_double), dimension(2,2,mx,my), intent(inout) :: p(:,:,:,:) - real(c_double), dimension(2,mx,my), intent(inout) :: z(:,:,:) + real(c_double), dimension(2, 2, mx, my), intent(inout) :: p(:, :, :, :) + real(c_double), dimension(2, mx, my), intent(inout) :: z(:, :, :) ! local variable integer(c_int64_t) :: i, j real(c_double) :: z1, z2 - - do i = 1,mx - do j = 1,my - z1 = z(1,i,j) - z2 = z(2,i,j) - z(1,i,j) = p(1,1,i,j) * z1 + p(1,2,i,j) * z2 - z(2,i,j) = p(2,1,i,j) * z1 + p(2,2,i,j) * z2 - end do + do i = 1, mx + do j = 1, my + z1 = z(1, i, j) + z2 = z(2, i, j) + z(1, i, j) = p(1, 1, i, j)*z1 + p(1, 2, i, j)*z2 + z(2, i, j) = p(2, 1, i, j)*z1 + p(2, 2, i, j)*z2 + end do end do return @@ -447,7 +446,6 @@ end subroutine Prec_Sol end module diurnal_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -474,12 +472,12 @@ program main integer(c_long) :: outstep ! output step real(c_double) :: x, y ! initialization index variables - type(N_Vector), pointer :: sunvec_u ! sundials vector - type(N_Vector), pointer :: sunvec_f ! sundials vector + type(N_Vector), pointer :: sunvec_u ! sundials vector + type(N_Vector), pointer :: sunvec_f ! sundials vector type(SUNLinearSolver), pointer :: sunls ! sundials linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) type(c_ptr) :: cvode_mem ! CVODE memory - real(c_double), pointer, dimension(2,mx,my) :: uvec(:,:,:) ! underlying vector + real(c_double), pointer, dimension(2, mx, my) :: uvec(:, :, :) ! underlying vector ! output statistic variables integer(c_long) :: lnst(1) @@ -492,84 +490,84 @@ program main ! initialize ODE tstart = 0.0d0 - tcur = tstart + tcur = tstart ! create SUNDIALS N_Vector sunvec_u => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_f => FN_VNew_Serial(neq, ctx) if (.not. associated(sunvec_f)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if - uvec(1:2,1:mx,1:my) => FN_VGetArrayPointer(sunvec_u) + uvec(1:2, 1:mx, 1:my) => FN_VGetArrayPointer(sunvec_u) ! initialize and fill initial condition vector - do jy = 1,my - y = 30.0d0 + (jy - 1.0d0) * dy - cy = (0.1d0 * (y - 40.0d0))**2 - cy = 1.0d0 - cy + 0.5d0 * cy**2 - do jx = 1,mx - x = (jx - 1.0d0) * dx - cx = (0.1d0 * (x - 10.0d0))**2 - cx = 1.0d0 - cx + 0.5d0 * cx**2 - uvec(1,jx,jy) = 1.0d6 * cx * cy - uvec(2,jx,jy) = 1.0d12 * cx * cy - end do + do jy = 1, my + y = 30.0d0 + (jy - 1.0d0)*dy + cy = (0.1d0*(y - 40.0d0))**2 + cy = 1.0d0 - cy + 0.5d0*cy**2 + do jx = 1, mx + x = (jx - 1.0d0)*dx + cx = (0.1d0*(x - 10.0d0))**2 + cx = 1.0d0 - cx + 0.5d0*cx**2 + uvec(1, jx, jy) = 1.0d6*cx*cy + uvec(2, jx, jy) = 1.0d12*cx*cy + end do end do ! create and initialize CVode memory cvode_mem = FCVodeCreate(CV_BDF, ctx) - if (.not. c_associated(cvode_mem)) print *,'ERROR: cvode_mem = NULL' + if (.not. c_associated(cvode_mem)) print *, 'ERROR: cvode_mem = NULL' ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_u) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeSetMaxNumSteps(cvode_mem, mxsteps) if (ierr /= 0) then - print *, 'Error in FCVodeSetMaxNumSteps, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetMaxNumSteps, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeSStolerances(cvode_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! Tell CVODE to use a SPGMR linear solver. sunls => FSUNLinSol_SPGMR(sunvec_u, Jpretype, maxL, ctx) if (.not. associated(sunls)) then - print *, 'ERROR: sunls = NULL' - stop 1 + print *, 'ERROR: sunls = NULL' + stop 1 end if ierr = FSUNLinSol_SPGMRSetGSType(sunls, iGStype) if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver' - stop 1 + print *, 'Error in FCVodeSetLinearSolver' + stop 1 end if ! Attach the linear solver (with NULL SUNMatrix object) sunmat_A => null() ierr = FCVodeSetLinearSolver(cvode_mem, sunls, sunmat_A) if (ierr /= 0) then - print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeSetPreconditioner(cvode_mem, c_funloc(PreSet), c_funloc(PreSolve)) if (ierr /= 0) then - print *, 'Error in FCVodeSetPreconditioner, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSetPreconditioner, ierr = ', ierr, '; halting' + stop 1 end if ! Start time stepping @@ -580,33 +578,33 @@ program main print *, ' t c2 (bottom left middle top right) | lnst lh' print *, ' -----------------------------------------------------------------------------------' tout = twohr - do outstep = 1,12 - - ! call CVode - ierr = FCVode(cvode_mem, tout, sunvec_u, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVode, ierr = ', ierr, '; halting' - stop 1 - end if - - ierr = FCVodeGetNumSteps(cvode_mem, lnst) - if (ierr /= 0) then - print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 - end if - - ierr = FCVodeGetCurrentStep(cvode_mem, lh) - if (ierr /= 0) then - print *, 'Error in FCVodeGetCurrentStep, ierr = ', ierr, '; halting' - stop 1 - end if - - ! print current solution and output statistics - print '(2x,4(es14.6,2x),i5,es14.6)', tcur, uvec(1,1,1), uvec(1,5,5), uvec(1,10,10), lnst, lh - print '(18x,3(es14.6,2x))', uvec(2,1,1), uvec(2,5,5), uvec(2,10,10) - - ! update tout - tout = tout + twohr + do outstep = 1, 12 + + ! call CVode + ierr = FCVode(cvode_mem, tout, sunvec_u, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVode, ierr = ', ierr, '; halting' + stop 1 + end if + + ierr = FCVodeGetNumSteps(cvode_mem, lnst) + if (ierr /= 0) then + print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 + end if + + ierr = FCVodeGetCurrentStep(cvode_mem, lh) + if (ierr /= 0) then + print *, 'Error in FCVodeGetCurrentStep, ierr = ', ierr, '; halting' + stop 1 + end if + + ! print current solution and output statistics + print '(2x,4(es14.6,2x),i5,es14.6)', tcur, uvec(1, 1, 1), uvec(1, 5, 5), uvec(1, 10, 10), lnst, lh + print '(18x,3(es14.6,2x))', uvec(2, 1, 1), uvec(2, 5, 5), uvec(2, 10, 10) + + ! update tout + tout = tout + twohr end do print *, ' -----------------------------------------------------------------------------------' @@ -661,86 +659,86 @@ subroutine CVodeStats(cvode_mem) ierr = FCVodeGetNumSteps(cvode_mem, nsteps) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumSteps, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumRhsEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumRhsEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumErrTestFails(cvode_mem, netfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumErrTestFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumErrTestFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumPrecEvals(cvode_mem, npe) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumPrecEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumPrecEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumPrecSolves(cvode_mem, nps) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumPrecSolves, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumPrecSolves, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumNonlinSolvIters(cvode_mem, nniters) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumLinIters(cvode_mem, nliters) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumLinIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinIters, ierr = ', ierr, '; halting' + stop 1 end if avdim = dble(nliters)/dble(nniters) ierr = FCVodeGetNumLinConvFails(cvode_mem, ncfl) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumLinConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetNumNonlinSolvConvFails(cvode_mem, ncf) if (ierr /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetWorkSpace(cvode_mem, lenrw, leniw) if (ierr /= 0) then - print *, 'Error in FCVodeGetWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ierr = FCVodeGetLinWorkSpace(cvode_mem, lenrwls, leniwls) if (ierr /= 0) then - print *, 'Error in FCVodeGetLinWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetLinWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function call =',nfe - print '(4x,A,i9)' ,'Total num preconditioner evals =',npe - print '(4x,A,i9)' ,'Total num preconditioner solves =',nps - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num linear solver iters =',nliters - print '(4x,A,es14.6)' ,'Avg Krylov subspace dim =',avdim - print '(4x,A,i9)' ,'Num nonlinear solver fails =',ncf - print '(4x,A,i9)' ,'Num linear solver fails =',ncfl - print '(4x,A,2(i9,3x))' ,'main solver real/int workspace sizes =',lenrw,leniw - print '(4x,A,2(i9,3x))' ,'linear solver real/int workspace sizes =',lenrwls,leniwls + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function call =', nfe + print '(4x,A,i9)', 'Total num preconditioner evals =', npe + print '(4x,A,i9)', 'Total num preconditioner solves =', nps + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num linear solver iters =', nliters + print '(4x,A,es14.6)', 'Avg Krylov subspace dim =', avdim + print '(4x,A,i9)', 'Num nonlinear solver fails =', ncf + print '(4x,A,i9)', 'Num linear solver fails =', ncfl + print '(4x,A,2(i9,3x))', 'main solver real/int workspace sizes =', lenrw, leniw + print '(4x,A,2(i9,3x))', 'linear solver real/int workspace sizes =', lenrwls, leniwls print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_roberts_dnsL_f2003.f90 b/examples/cvode/F2003_serial/cv_roberts_dnsL_f2003.f90 index 2ed0a8cbed..5c5b5078b4 100644 --- a/examples/cvode/F2003_serial/cv_roberts_dnsL_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_roberts_dnsL_f2003.f90 @@ -58,7 +58,7 @@ module robertsDnsL_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='fcnrob') + result(ierr) bind(C, name='fcnrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -70,7 +70,7 @@ integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! function N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -79,13 +79,13 @@ integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & !======= Internals ============ ! get data arrays from SUNDIALS vectors - yval => FN_VGetArrayPointer(sunvec_y) - fval => FN_VGetArrayPointer(sunvec_f) + yval => FN_VGetArrayPointer(sunvec_y) + fval => FN_VGetArrayPointer(sunvec_f) ! fill residual vector - fval(1) = -0.04d0*yval(1) + 1.0d4*yval(2)*yval(3) - fval(3) = 3.0d7*yval(2)**2 - fval(2) = -fval(1) - fval(3) + fval(1) = -0.04d0*yval(1) + 1.0d4*yval(2)*yval(3) + fval(3) = 3.0d7*yval(2)**2 + fval(2) = -fval(1) - fval(3) ! return success ierr = 0 @@ -103,7 +103,7 @@ end function fcnrob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function grob(t, sunvec_y, gout, user_data) & - result(ierr) bind(C,name='grob') + result(ierr) bind(C, name='grob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -115,7 +115,7 @@ integer(c_int) function grob(t, sunvec_y, gout, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector real(c_double) :: gout(2) ! root function values - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -145,8 +145,8 @@ end function grob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & - sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='jacrob') + sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='jacrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -160,15 +160,14 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! residual N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 ! pointers to data in SUNDIALS vector and matrix real(c_double), pointer, dimension(neq) :: yval(:) - real(c_double), pointer, dimension(neq,neq) :: J(:,:) - + real(c_double), pointer, dimension(neq, neq) :: J(:, :) !======= Internals ============ @@ -177,15 +176,15 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & J(1:3, 1:3) => FSUNDenseMatrix_Data(sunmat_J) ! fill Jacobian entries - J(1,1) = -0.04d0 - J(2,1) = 0.04d0 - J(3,1) = 0.0d0 - J(1,2) = 1.0d4*yval(3) - J(2,2) = -1.0d4*yval(3) - 6.0d7*yval(2) - J(3,2) = 6.0d7*yval(2) - J(1,3) = 1.0d4*yval(2) - J(2,3) = -1.0d4*yval(2) - J(3,3) = 0.0d0 + J(1, 1) = -0.04d0 + J(2, 1) = 0.04d0 + J(3, 1) = 0.0d0 + J(1, 2) = 1.0d4*yval(3) + J(2, 2) = -1.0d4*yval(3) - 6.0d7*yval(2) + J(3, 2) = 6.0d7*yval(2) + J(1, 3) = 1.0d4*yval(2) + J(2, 3) = -1.0d4*yval(2) + J(3, 3) = 0.0d0 ! return success ierr = 0 @@ -197,7 +196,6 @@ end function jacrob end module robertsDnsL_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -219,10 +217,10 @@ program main real(c_double) :: rtol, t0, tout, tret(1) integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2) - type(N_Vector), pointer :: sunvec_y ! sundials solution vector - type(N_Vector), pointer :: sunvec_dky ! sundials solution vector - type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_dky ! sundials solution vector + type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: cvode_mem ! CVode memory type(c_ptr) :: sunctx ! SUNDIALS simulation context @@ -248,14 +246,14 @@ program main ! create serial vectors sunvec_y => FN_VMake_Serial(neq, yval, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_av => FN_VMake_Serial(neq, avtol, sunctx) if (.not. associated(sunvec_av)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! set limits @@ -270,92 +268,92 @@ program main retval = FCVodeInit(cvode_mem, c_funloc(fcnrob), t0, sunvec_y) if (retval /= 0) then - print *, 'Error in FCVodeInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeInit, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeSVtolerances to set tolerances retval = FCVodeSVtolerances(cvode_mem, rtol, sunvec_av) if (retval /= 0) then - print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeRootInit to specify the root function grob with 2 components nrtfn = 2 retval = FCVodeRootInit(cvode_mem, nrtfn, c_funloc(grob)) if (retval /= 0) then - print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' + stop 1 end if ! Create dense SUNMatrix for use in linear solves sunmat_A => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! Create dense SUNLinearSolver object sunlinsol_LS => FSUNLinSol_LapackDense(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! Attach the matrix and linear solver - retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); + retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); if (retval /= 0) then - print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the user-supplied Jacobian routine retval = FCVodeSetJacFn(cvode_mem, c_funloc(jacrob)) if (retval /= 0) then - print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' + stop 1 end if ! In loop, call FCVode, print results, and test for error. iout = 0 - do while(iout < nout) + do while (iout < nout) + + retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) + if (retval < 0) then + print *, 'Error in FCVode, retval = ', retval, '; halting' + stop 1 + end if - retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) - if (retval < 0) then - print *, 'Error in FCVode, retval = ', retval, '; halting' + call PrintOutput(cvode_mem, tret(1), yval) + + if (retval == CV_ROOT_RETURN) then + retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) + if (retvalr < 0) then + print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' stop 1 - end if - - call PrintOutput(cvode_mem, tret(1), yval) - - if (retval .eq. CV_ROOT_RETURN) then - retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) - if (retvalr < 0) then - print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' - stop 1 - end if - print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) - end if - - if (retval .eq. CV_SUCCESS) then - iout = iout + 1 - tout = tout * 10.0d0 - end if + end if + print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) + end if + + if (retval == CV_SUCCESS) then + iout = iout + 1 + tout = tout*10.0d0 + end if end do sunvec_dky => FN_VMake_Serial(neq, dkyval, sunctx) if (.not. associated(sunvec_dky)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! find and print derivative at tret(1) retval = FCVodeGetDky(cvode_mem, tret(1), 1, sunvec_dky) if (retval /= 0) then - print *, 'Error in CVodeGetDky' - stop 1 + print *, 'Error in CVodeGetDky' + stop 1 end if print *, " " print *, "------------------------------------------------------" @@ -377,7 +375,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -402,8 +399,8 @@ subroutine PrintHeader(rtol, avtol, y) print *, " Three equation chemical kinetics problem." print *, " " print *, "Linear solver: LAPACK DENSE, with user-supplied Jacobian." - print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ",rtol," atol = ", avtol - print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")" + print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ", rtol, " atol = ", avtol + print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (", y, ")" print *, " " print *, "---------------------------------------------------" print *, " t y1 y2 y3" @@ -413,7 +410,6 @@ subroutine PrintHeader(rtol, avtol, y) end subroutine PrintHeader ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -437,7 +433,6 @@ subroutine PrintOutput(cvode_mem, t, y) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -469,62 +464,62 @@ subroutine PrintFinalStats(cvode_mem) retval = FCVodeGetNumSteps(cvode_mem, nsteps) if (retval /= 0) then - print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (retval /= 0) then - print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumLinSolvSetups(cvode_mem, nluevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumErrTestFails(cvode_mem, netfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nniters) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, nncfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumJacEvals(cvode_mem, njacevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumGEvals(cvode_mem, ngevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfe - print '(4x,A,i9)' ,'Total Jacobian function calls =',njacevals - print '(4x,A,i9)' ,'Total root function calls =',ngevals - print '(4x,A,i9)' ,'Total LU function calls =',nluevals - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfe + print '(4x,A,i9)', 'Total Jacobian function calls =', njacevals + print '(4x,A,i9)', 'Total root function calls =', ngevals + print '(4x,A,i9)', 'Total LU function calls =', nluevals + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_roberts_dns_constraints_f2003.f90 b/examples/cvode/F2003_serial/cv_roberts_dns_constraints_f2003.f90 index 1eb2e504be..6f9c6e7576 100644 --- a/examples/cvode/F2003_serial/cv_roberts_dns_constraints_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_roberts_dns_constraints_f2003.f90 @@ -62,7 +62,7 @@ module RobertsDnsConstr_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='fcnrob') + result(ierr) bind(C, name='fcnrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -74,7 +74,7 @@ integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! function N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -107,7 +107,7 @@ end function fcnrob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function grob(t, sunvec_y, gout, user_data) & - result(ierr) bind(C,name='grob') + result(ierr) bind(C, name='grob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -119,7 +119,7 @@ integer(c_int) function grob(t, sunvec_y, gout, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector real(c_double) :: gout(2) ! root function values - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -149,8 +149,8 @@ end function grob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & - sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='jacrob') + sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='jacrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -164,15 +164,14 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! residual N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 ! pointers to data in SUNDIALS vector and matrix real(c_double), pointer, dimension(neq) :: yval(:) - real(c_double), pointer, dimension(neq,neq) :: J(:,:) - + real(c_double), pointer, dimension(neq, neq) :: J(:, :) !======= Internals ============ @@ -181,15 +180,15 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & J(1:3, 1:3) => FSUNDenseMatrix_Data(sunmat_J) ! fill Jacobian entries - J(1,1) = -0.04d0 - J(2,1) = 0.04d0 - J(3,1) = 0.0d0 - J(1,2) = 1.0d4*yval(3) - J(2,2) = -1.0d4*yval(3) - 6.0d7*yval(2) - J(3,2) = 6.0d7*yval(2) - J(1,3) = 1.0d4*yval(2) - J(2,3) = -1.0d4*yval(2) - J(3,3) = 0.0d0 + J(1, 1) = -0.04d0 + J(2, 1) = 0.04d0 + J(3, 1) = 0.0d0 + J(1, 2) = 1.0d4*yval(3) + J(2, 2) = -1.0d4*yval(3) - 6.0d7*yval(2) + J(3, 2) = 6.0d7*yval(2) + J(1, 3) = 1.0d4*yval(2) + J(2, 3) = -1.0d4*yval(2) + J(3, 3) = 0.0d0 ! return success ierr = 0 @@ -201,7 +200,6 @@ end function jacrob end module RobertsDnsConstr_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -223,11 +221,11 @@ program main real(c_double) :: rtol, t0, tout, tret(1) integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2) - type(N_Vector), pointer :: sunvec_y ! sundials solution vector - type(N_Vector), pointer :: sunvec_c ! sundials constraint vector - type(N_Vector), pointer :: sunvec_dky ! sundials solution vector - type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_c ! sundials constraint vector + type(N_Vector), pointer :: sunvec_dky ! sundials solution vector + type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: cvode_mem ! CVode memory type(c_ptr) :: sunctx ! SUNDIALS simulation context @@ -256,20 +254,20 @@ program main ! create serial vectors sunvec_y => FN_VMake_Serial(neq, yval, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_c => FN_VMake_Serial(neq, cval, sunctx) if (.not. associated(sunvec_c)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_av => FN_VMake_Serial(neq, avtol, sunctx) if (.not. associated(sunvec_av)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! set limits @@ -284,98 +282,98 @@ program main retval = FCVodeInit(cvode_mem, c_funloc(fcnrob), t0, sunvec_y) if (retval /= 0) then - print *, 'Error in FCVodeInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeInit, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeSVtolerances to set tolerances retval = FCVodeSVtolerances(cvode_mem, rtol, sunvec_av) if (retval /= 0) then - print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeRootInit to specify the root function grob with 2 components nrtfn = 2 retval = FCVodeRootInit(cvode_mem, nrtfn, c_funloc(grob)) if (retval /= 0) then - print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' + stop 1 end if ! Create dense SUNMatrix for use in linear solves sunmat_A => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! Create dense SUNLinearSolver object sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! Attach the matrix and linear solver - retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); + retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); if (retval /= 0) then - print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the user-supplied Jacobian routine retval = FCVodeSetJacFn(cvode_mem, c_funloc(jacrob)) if (retval /= 0) then - print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeSetConstraints(cvode_mem, sunvec_c) if (retval /= 0) then - print *, 'Error in FCVodeSetConstraints, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetConstraints, retval = ', retval, '; halting' + stop 1 end if ! In loop, call FCVode, print results, and test for error. iout = 0 - do while(iout < nout) + do while (iout < nout) + + retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) + if (retval < 0) then + print *, 'Error in FCVode, retval = ', retval, '; halting' + stop 1 + end if + + call PrintOutput(cvode_mem, tret(1), yval) - retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) - if (retval < 0) then - print *, 'Error in FCVode, retval = ', retval, '; halting' + if (retval == CV_ROOT_RETURN) then + retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) + if (retvalr < 0) then + print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' stop 1 - end if - - call PrintOutput(cvode_mem, tret(1), yval) - - if (retval .eq. CV_ROOT_RETURN) then - retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) - if (retvalr < 0) then - print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' - stop 1 - end if - print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) - end if - - if (retval .eq. CV_SUCCESS) then - iout = iout + 1 - tout = tout * 10.0d0 - end if + end if + print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) + end if + + if (retval == CV_SUCCESS) then + iout = iout + 1 + tout = tout*10.0d0 + end if end do sunvec_dky => FN_VMake_Serial(neq, dkyval, sunctx) if (.not. associated(sunvec_dky)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! find and print derivative at tret(1) retval = FCVodeGetDky(cvode_mem, tret(1), 1, sunvec_dky) if (retval /= 0) then - print *, 'Error in CVodeGetDky' - stop 1 + print *, 'Error in CVodeGetDky' + stop 1 end if print *, " " print *, "---------------------------------------------------" @@ -398,7 +396,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -423,9 +420,9 @@ subroutine PrintHeader(rtol, avtol, y, c) print *, " Three equation chemical kinetics problem." print *, " " print *, "Linear solver: DENSE, with user-supplied Jacobian." - print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ",rtol," atol = ", avtol - print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")" - print '(a,3(f5.2,1x),a)', "Constraints cval = (",c,")" + print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ", rtol, " atol = ", avtol + print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (", y, ")" + print '(a,3(f5.2,1x),a)', "Constraints cval = (", c, ")" print *, " " print *, "---------------------------------------------------" print *, " t y1 y2 y3" @@ -435,7 +432,6 @@ subroutine PrintHeader(rtol, avtol, y, c) end subroutine PrintHeader ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -460,7 +456,6 @@ subroutine PrintOutput(cvode_mem, t, y) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -492,62 +487,62 @@ subroutine PrintFinalStats(cvode_mem) retval = FCVodeGetNumSteps(cvode_mem, nsteps) if (retval /= 0) then - print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (retval /= 0) then - print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumLinSolvSetups(cvode_mem, nluevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumErrTestFails(cvode_mem, netfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nniters) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, nncfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumJacEvals(cvode_mem, njacevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumGEvals(cvode_mem, ngevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfe - print '(4x,A,i9)' ,'Total Jacobian function calls =',njacevals - print '(4x,A,i9)' ,'Total root function calls =',ngevals - print '(4x,A,i9)' ,'Total LU function calls =',nluevals - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfe + print '(4x,A,i9)', 'Total Jacobian function calls =', njacevals + print '(4x,A,i9)', 'Total root function calls =', ngevals + print '(4x,A,i9)', 'Total LU function calls =', nluevals + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_roberts_dns_f2003.f90 b/examples/cvode/F2003_serial/cv_roberts_dns_f2003.f90 index 3a07939e64..5cbe7aaddd 100644 --- a/examples/cvode/F2003_serial/cv_roberts_dns_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_roberts_dns_f2003.f90 @@ -44,7 +44,7 @@ module robertsDns_mod !======= Declarations ========= implicit none - integer(c_int), parameter :: nout = 12 + integer(c_int), parameter :: nout = 12 integer(c_int64_t), parameter :: neq = 3 contains @@ -58,7 +58,7 @@ module robertsDns_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='fcnrob') + result(ierr) bind(C, name='fcnrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -70,7 +70,7 @@ integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! function N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -103,7 +103,7 @@ end function fcnrob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function grob(t, sunvec_y, gout, user_data) & - result(ierr) bind(C,name='grob') + result(ierr) bind(C, name='grob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -115,7 +115,7 @@ integer(c_int) function grob(t, sunvec_y, gout, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector real(c_double) :: gout(2) ! root function values - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -145,8 +145,8 @@ end function grob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & - sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='jacrob') + sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='jacrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -160,15 +160,14 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! residual N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 ! pointers to data in SUNDIALS vector and matrix real(c_double), pointer, dimension(neq) :: yval(:) - real(c_double), pointer, dimension(neq,neq) :: J(:,:) - + real(c_double), pointer, dimension(neq, neq) :: J(:, :) !======= Internals ============ @@ -177,15 +176,15 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & J(1:3, 1:3) => FSUNDenseMatrix_Data(sunmat_J) ! fill Jacobian entries - J(1,1) = -0.04d0 - J(2,1) = 0.04d0 - J(3,1) = 0.0d0 - J(1,2) = 1.0d4*yval(3) - J(2,2) = -1.0d4*yval(3) - 6.0d7*yval(2) - J(3,2) = 6.0d7*yval(2) - J(1,3) = 1.0d4*yval(2) - J(2,3) = -1.0d4*yval(2) - J(3,3) = 0.0d0 + J(1, 1) = -0.04d0 + J(2, 1) = 0.04d0 + J(3, 1) = 0.0d0 + J(1, 2) = 1.0d4*yval(3) + J(2, 2) = -1.0d4*yval(3) - 6.0d7*yval(2) + J(3, 2) = 6.0d7*yval(2) + J(1, 3) = 1.0d4*yval(2) + J(2, 3) = -1.0d4*yval(2) + J(3, 3) = 0.0d0 ! return success ierr = 0 @@ -197,7 +196,6 @@ end function jacrob end module robertsDns_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -216,11 +214,11 @@ program main real(c_double) :: rtol, t0, tout, tret(1) integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2) - type(N_Vector), pointer :: sunvec_y ! sundials solution vector - type(N_Vector), pointer :: sunvec_dky ! sundials solution vector - type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix - type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_dky ! sundials solution vector + type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: cvode_mem ! CVode memory type(c_ptr) :: sunctx ! SUNDIALS simulation context @@ -245,14 +243,14 @@ program main ! create serial vectors sunvec_y => FN_VMake_Serial(neq, yval, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_av => FN_VMake_Serial(neq, avtol, sunctx) if (.not. associated(sunvec_av)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! set limits @@ -267,92 +265,92 @@ program main retval = FCVodeInit(cvode_mem, c_funloc(fcnrob), t0, sunvec_y) if (retval /= 0) then - print *, 'Error in FCVodeInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeInit, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeSVtolerances to set tolerances retval = FCVodeSVtolerances(cvode_mem, rtol, sunvec_av) if (retval /= 0) then - print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeRootInit to specify the root function grob with 2 components nrtfn = 2 retval = FCVodeRootInit(cvode_mem, nrtfn, c_funloc(grob)) if (retval /= 0) then - print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' + stop 1 end if ! Create dense SUNMatrix for use in linear solves sunmat_A => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! Create dense SUNLinearSolver object sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! Attach the matrix and linear solver - retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); + retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); if (retval /= 0) then - print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the user-supplied Jacobian routine retval = FCVodeSetJacFn(cvode_mem, c_funloc(jacrob)) if (retval /= 0) then - print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' + stop 1 end if ! In loop, call FCVode, print results, and test for error. iout = 0 - do while(iout < nout) + do while (iout < nout) + + retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) + if (retval < 0) then + print *, 'Error in FCVode, retval = ', retval, '; halting' + stop 1 + end if + + call PrintOutput(cvode_mem, tret(1), yval) - retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) - if (retval < 0) then - print *, 'Error in FCVode, retval = ', retval, '; halting' + if (retval == CV_ROOT_RETURN) then + retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) + if (retvalr < 0) then + print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' stop 1 - end if - - call PrintOutput(cvode_mem, tret(1), yval) - - if (retval .eq. CV_ROOT_RETURN) then - retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) - if (retvalr < 0) then - print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' - stop 1 - end if - print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) - end if - - if (retval .eq. CV_SUCCESS) then - iout = iout + 1 - tout = tout * 10.0d0 - end if + end if + print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) + end if + + if (retval == CV_SUCCESS) then + iout = iout + 1 + tout = tout*10.0d0 + end if end do sunvec_dky => FN_VMake_Serial(neq, dkyval, sunctx) if (.not. associated(sunvec_dky)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! find and print derivative at tret(1) retval = FCVodeGetDky(cvode_mem, tret(1), 1, sunvec_dky) if (retval /= 0) then - print *, 'Error in CVodeGetDky' - stop 1 + print *, 'Error in CVodeGetDky' + stop 1 end if print *, " " print *, "---------------------------------------------------" @@ -374,7 +372,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -399,8 +396,8 @@ subroutine PrintHeader(rtol, avtol, y) print *, " Three equation chemical kinetics problem." print *, " " print *, "Linear solver: DENSE, with user-supplied Jacobian." - print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ",rtol," atol = ", avtol - print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")" + print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ", rtol, " atol = ", avtol + print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (", y, ")" print *, "Constraints not used." print *, " " print *, "---------------------------------------------------" @@ -411,7 +408,6 @@ subroutine PrintHeader(rtol, avtol, y) end subroutine PrintHeader ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -435,7 +431,6 @@ subroutine PrintOutput(cvode_mem, t, y) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -467,62 +462,62 @@ subroutine PrintFinalStats(cvode_mem) retval = FCVodeGetNumSteps(cvode_mem, nsteps) if (retval /= 0) then - print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (retval /= 0) then - print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumLinSolvSetups(cvode_mem, nluevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumErrTestFails(cvode_mem, netfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nniters) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, nncfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumJacEvals(cvode_mem, njacevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumGEvals(cvode_mem, ngevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfe - print '(4x,A,i9)' ,'Total Jacobian function calls =',njacevals - print '(4x,A,i9)' ,'Total root function calls =',ngevals - print '(4x,A,i9)' ,'Total LU function calls =',nluevals - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfe + print '(4x,A,i9)', 'Total Jacobian function calls =', njacevals + print '(4x,A,i9)', 'Total root function calls =', ngevals + print '(4x,A,i9)', 'Total LU function calls =', nluevals + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/cvode/F2003_serial/cv_roberts_klu_f2003.f90 b/examples/cvode/F2003_serial/cv_roberts_klu_f2003.f90 index 785d3e7c63..5e108501bd 100644 --- a/examples/cvode/F2003_serial/cv_roberts_klu_f2003.f90 +++ b/examples/cvode/F2003_serial/cv_roberts_klu_f2003.f90 @@ -46,7 +46,7 @@ module roberts_klu_mod integer(c_int), parameter :: nout = 12 integer(c_int64_t), parameter :: neq = 3 - integer(c_int64_t), parameter :: nnz = neq * neq + integer(c_int64_t), parameter :: nnz = neq*neq contains @@ -59,7 +59,7 @@ module roberts_klu_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='fcnrob') + result(ierr) bind(C, name='fcnrob') !======= Inclusions =========== @@ -70,7 +70,7 @@ integer(c_int) function fcnrob(t, sunvec_y, sunvec_f, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! function N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -103,7 +103,7 @@ end function fcnrob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function grob(t, sunvec_y, gout, user_data) & - result(ierr) bind(C,name='grob') + result(ierr) bind(C, name='grob') !======= Declarations ========= implicit none @@ -112,7 +112,7 @@ integer(c_int) function grob(t, sunvec_y, gout, user_data) & real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector real(c_double) :: gout(2) ! root function values - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer, dimension(neq) :: yval(:) @@ -142,8 +142,8 @@ end function grob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & - sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='jacrob') + sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='jacrob') !======= Inclusions =========== use fsunmatrix_sparse_mod @@ -156,7 +156,7 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! unused N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 @@ -165,13 +165,13 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & real(c_double), pointer, dimension(neq) :: yval(:) real(c_double), pointer, dimension(nnz) :: Jdata(:) integer(c_int64_t), pointer, dimension(nnz) :: Jrvals(:) - integer(c_int64_t), pointer, dimension(neq+1) :: Jcptrs(:) + integer(c_int64_t), pointer, dimension(neq + 1) :: Jcptrs(:) !======= Internals ============ ! get data arrays from SUNDIALS vectors yval(1:neq) => FN_VGetArrayPointer(sunvec_y) - Jcptrs(1:neq+1) => FSUNSparseMatrix_IndexPointers(sunmat_J) + Jcptrs(1:neq + 1) => FSUNSparseMatrix_IndexPointers(sunmat_J) Jrvals(1:nnz) => FSUNSparseMatrix_IndexValues(sunmat_J) Jdata(1:nnz) => FSUNSparseMatrix_Data(sunmat_J) @@ -191,7 +191,6 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & Jdata(3) = 0.0d0 Jrvals(3) = 2 - Jdata(4) = 1.0d4*yval(3) Jrvals(4) = 0 @@ -201,7 +200,6 @@ integer(c_int) function jacrob(t, sunvec_y, sunvec_f, & Jdata(6) = 6.0d7*yval(2) Jrvals(6) = 2 - Jdata(7) = 1.0d4*yval(2) Jrvals(7) = 0 @@ -221,7 +219,6 @@ end function jacrob end module roberts_klu_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -239,10 +236,10 @@ program main real(c_double) :: rtol, t0, tout, tret(1) integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2) - type(N_Vector), pointer :: sunvec_y ! sundials solution vector - type(N_Vector), pointer :: sunvec_dky ! sundials solution vector - type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_dky ! sundials solution vector + type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: cvode_mem ! CVode memory type(c_ptr) :: sunctx ! SUNDIALS simulation context @@ -270,20 +267,20 @@ program main avtol(2) = 1.0d-12 avtol(3) = 1.0d-4 - initsize = 1.0d-4 * rtol - nlscoef = 1.0d-4 + initsize = 1.0d-4*rtol + nlscoef = 1.0d-4 ! create serial vectors sunvec_y => FN_VMake_Serial(neq, yval, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_av => FN_VMake_Serial(neq, avtol, sunctx) if (.not. associated(sunvec_av)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! set limits @@ -298,116 +295,116 @@ program main retval = FCVodeInit(cvode_mem, c_funloc(fcnrob), t0, sunvec_y) if (retval /= 0) then - print *, 'Error in FCVodeInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeInit, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeSVtolerances to set tolerances retval = FCVodeSVtolerances(cvode_mem, rtol, sunvec_av) if (retval /= 0) then - print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSVtolerances, retval = ', retval, '; halting' + stop 1 end if ! Call FCVodeRootInit to specify the root function grob with 2 components nrtfn = 2 retval = FCVodeRootInit(cvode_mem, nrtfn, c_funloc(grob)) if (retval /= 0) then - print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeRootInit, retval = ', retval, '; halting' + stop 1 end if ! Create sparse SUNMatrix for use in linear solves sunmat_A => FSUNSparseMatrix(neq, neq, nnz, CSC_MAT, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! Create KLU sparse SUNLinearSolver object sunlinsol_LS => FSUNLinSol_KLU(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if retval = FCVodeSetMaxNumSteps(cvode_mem, mxsteps) if (retval /= 0) then - print *, 'Error in FCVodeSetMaxNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetMaxNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeSetMaxErrTestFails(cvode_mem, maxetf) if (retval /= 0) then - print *, 'Error in FCVodeSetMaxErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetMaxErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeSetInitStep(cvode_mem, initsize) if (retval /= 0) then - print *, 'Error in FCVodeSetInitStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetInitStep, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeSetNonlinConvCoef(cvode_mem, nlscoef) if (retval /= 0) then - print *, 'Error in FCVodeSetNonlinConvCoef, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetNonlinConvCoef, retval = ', retval, '; halting' + stop 1 end if ! Attach the matrix and linear solver - retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); + retval = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A); if (retval /= 0) then - print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the user-supplied Jacobian routine retval = FCVodeSetJacFn(cvode_mem, c_funloc(jacrob)) if (retval /= 0) then - print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeSetJacFn, retval = ', retval, '; halting' + stop 1 end if ! In loop, call FCVode, print results, and test for error. iout = 0 - do while(iout < nout) + do while (iout < nout) + + retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) + if (retval < 0) then + print *, 'Error in FCVode, retval = ', retval, '; halting' + stop 1 + end if - retval = FCVode(cvode_mem, tout, sunvec_y, tret(1), CV_NORMAL) - if (retval < 0) then - print *, 'Error in FCVode, retval = ', retval, '; halting' + call PrintOutput(cvode_mem, tret(1), yval) + + if (retval == CV_ROOT_RETURN) then + retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) + if (retvalr < 0) then + print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' stop 1 - end if - - call PrintOutput(cvode_mem, tret(1), yval) - - if (retval .eq. CV_ROOT_RETURN) then - retvalr = FCVodeGetRootInfo(cvode_mem, rootsfound) - if (retvalr < 0) then - print *, 'Error in FCVodeGetRootInfo, retval = ', retval, '; halting' - stop 1 - end if - print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) - end if - - if (retval .eq. CV_SUCCESS) then - iout = iout + 1 - tout = tout * 10.0d0 - end if + end if + print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) + end if + + if (retval == CV_SUCCESS) then + iout = iout + 1 + tout = tout*10.0d0 + end if end do sunvec_dky => FN_VMake_Serial(neq, dkyval, sunctx) if (.not. associated(sunvec_dky)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! find and print derivative at tret(1) retval = FCVodeGetDky(cvode_mem, tret(1), 1, sunvec_dky) if (retval /= 0) then - print *, 'Error in CVodeGetDky' - stop 1 + print *, 'Error in CVodeGetDky' + stop 1 end if print *, " " print *, "---------------------------------------------------" @@ -429,7 +426,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -454,8 +450,8 @@ subroutine PrintHeader(rtol, avtol, y) print *, " Three equation chemical kinetics problem." print *, " " print *, "Linear solver: DENSE, with user-supplied Jacobian." - print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ",rtol," atol = ", avtol - print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")" + print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ", rtol, " atol = ", avtol + print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (", y, ")" print *, "Constraints not used." print *, " " print *, "---------------------------------------------------" @@ -466,7 +462,6 @@ subroutine PrintHeader(rtol, avtol, y) end subroutine PrintHeader ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -490,7 +485,6 @@ subroutine PrintOutput(cvode_mem, t, y) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -522,62 +516,62 @@ subroutine PrintFinalStats(cvode_mem) retval = FCVodeGetNumSteps(cvode_mem, nsteps) if (retval /= 0) then - print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumRhsEvals(cvode_mem, nfe) if (retval /= 0) then - print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumRhsEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumLinSolvSetups(cvode_mem, nluevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumLinSolvSetups, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumErrTestFails(cvode_mem, netfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvIters(cvode_mem, nniters) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumNonlinSolvConvFails(cvode_mem, nncfails) if (retval /= 0) then - print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumJacEvals(cvode_mem, njacevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumJacEvals, retval = ', retval, '; halting' + stop 1 end if retval = FCVodeGetNumGEvals(cvode_mem, ngevals) if (retval /= 0) then - print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FCVodeGetNumGEvals, retval = ', retval, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfe - print '(4x,A,i9)' ,'Total Jacobian function calls =',njacevals - print '(4x,A,i9)' ,'Total root function calls =',ngevals - print '(4x,A,i9)' ,'Total LU function calls =',nluevals - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfe + print '(4x,A,i9)', 'Total Jacobian function calls =', njacevals + print '(4x,A,i9)', 'Total root function calls =', ngevals + print '(4x,A,i9)', 'Total LU function calls =', nluevals + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/cvodes/F2003_serial/cvsAdvDiff_FSA_non_f2003.f90 b/examples/cvodes/F2003_serial/cvsAdvDiff_FSA_non_f2003.f90 index 25e75a14c5..e42e33e0b8 100644 --- a/examples/cvodes/F2003_serial/cvsAdvDiff_FSA_non_f2003.f90 +++ b/examples/cvodes/F2003_serial/cvsAdvDiff_FSA_non_f2003.f90 @@ -56,7 +56,6 @@ module ode_problem use fsundials_core_mod implicit none - ! Since SUNDIALS can be compiled with 32-bit or 64-bit sunindextype ! we set the integer kind used for indices in this example based ! on the the index size SUNDIALS was compiled with so that it works @@ -71,22 +70,22 @@ module ode_problem type(c_ptr) :: ctx ! problem parameters - real(c_double), parameter :: XMAX = 2.0d0 - real(c_double), parameter :: T0 = 0.0d0 - real(c_double), parameter :: T1 = 0.5d0 - real(c_double), parameter :: DTOUT = 0.5d0 - real(c_double), parameter :: ATOL = 1e-5 - integer(c_int), parameter :: NOUT = 10 - integer(c_int), parameter :: NP = 2 - integer(c_int), parameter :: NS = 2 - integer(kind=myindextype), parameter :: MX = 10 + real(c_double), parameter :: XMAX = 2.0d0 + real(c_double), parameter :: T0 = 0.0d0 + real(c_double), parameter :: T1 = 0.5d0 + real(c_double), parameter :: DTOUT = 0.5d0 + real(c_double), parameter :: ATOL = 1e-5 + integer(c_int), parameter :: NOUT = 10 + integer(c_int), parameter :: NP = 2 + integer(c_int), parameter :: NS = 2 + integer(kind=myindextype), parameter :: MX = 10 integer(kind=myindextype), parameter :: NEQ = MX ! problem constants - real(c_double) :: ZERO = 0.d0 + real(c_double) :: ZERO = 0.d0 ! problem data - real(c_double) :: p(0:NP-1) + real(c_double) :: p(0:NP - 1) real(c_double) :: dx contains @@ -101,7 +100,7 @@ module ode_problem ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, nv_u, nv_udot, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -114,7 +113,7 @@ integer(c_int) function RhsFn(tn, nv_u, nv_udot, user_data) & real(c_double), value :: tn ! current time type(N_Vector) :: nv_u ! solution N_Vector type(N_Vector) :: nv_udot ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: u(:) @@ -134,28 +133,28 @@ integer(c_int) function RhsFn(tn, nv_u, nv_udot, user_data) & !======= Internals ============ ! get data arrays from SUNDIALS vectors - u => FN_VGetArrayPointer(nv_u) + u => FN_VGetArrayPointer(nv_u) udot => FN_VGetArrayPointer(nv_udot) ! loop over all grid points - do i=1, NEQ + do i = 1, NEQ ui = u(i) if (i /= 1) then - ult = u(i-1) + ult = u(i - 1) else ult = ZERO - endif + end if if (i /= NEQ) then - urt = u(i+1) + urt = u(i + 1) else urt = ZERO - endif + end if ! set diffusion and avection terms and load into udot - hdiff = hordc*(ult - 2.0d0*ui + urt) - hadv = horac*(urt - ult) + hdiff = hordc*(ult - 2.0d0*ui + urt) + hadv = horac*(urt - ult) udot(i) = hdiff + hadv end do @@ -180,7 +179,7 @@ subroutine SetIC(nv_u) u => FN_VGetArrayPointer(nv_u) ! Load initial profile into u vector - do i=1, NEQ + do i = 1, NEQ x = i*dx u(i) = x*(XMAX - x)*exp(2.0d0*x) end do @@ -204,15 +203,15 @@ program main ! Local variables type(c_ptr) :: cvodes_mem - type(N_Vector), pointer :: u, uiS + type(N_Vector), pointer :: u, uiS type(c_ptr) :: uS type(SUNNonlinearSolver), pointer :: NLS type(SUNNonlinearSolver), pointer :: NLSsens => null() integer(c_int) :: iout, retval real(c_double) :: reltol, abstol, tout, t(1) - integer(c_int) :: plist(0:NS-1) + integer(c_int) :: plist(0:NS - 1) integer(c_int) :: is - real(c_double) :: pbar(0:NS-1) + real(c_double) :: pbar(0:NS - 1) ! Command line arguments integer(c_int) :: sensi, err_con @@ -224,21 +223,21 @@ program main ! Create SUNDIALS simulation context retval = FSUNContext_Create(SUN_COMM_NULL, ctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ",retval - stop 1 + print *, "Error: FSUNContext_Create returned ", retval + stop 1 end if ! Set problem data - dx = XMAX/(MX+1) + dx = XMAX/(MX + 1) p(0) = 1.0d0 p(1) = 0.5d0 ! Allocate and set initial states u => FN_VNew_Serial(NEQ, ctx) if (.not. associated(u)) then - write(*,*) 'ERROR: FN_VNew_Serial returned NULL' + write (*, *) 'ERROR: FN_VNew_Serial returned NULL' stop 1 - endif + end if call SetIC(u) ! Set integration tolerances @@ -248,9 +247,9 @@ program main ! Create CVODES object cvodes_mem = FCVodeCreate(CV_ADAMS, ctx) if (.not. c_associated(cvodes_mem)) then - write(*,*) 'ERROR: cvodes_mem = NULL' + write (*, *) 'ERROR: cvodes_mem = NULL' stop 1 - endif + end if ! Initialize CVode retval = FCVodeInit(cvodes_mem, c_funloc(RhsFn), T0, u) @@ -263,32 +262,32 @@ program main ! Create fixed point nonlinear solver object NLS => FSUNNonlinSol_FixedPoint(u, 0, ctx) if (.not. associated(NLS)) then - write(*,*) 'ERROR: FSUNNonlinSol_FixedPoint returned NULL' + write (*, *) 'ERROR: FSUNNonlinSol_FixedPoint returned NULL' stop 1 - endif + end if ! Attach nonlinear solver object to CVode retval = FCVodeSetNonlinearSolver(cvodes_mem, NLS) call check_retval(retval, "FCVodeSetNonlinearSolver") - write(*,*) "" + write (*, *) "" print '(A,i3)', "1-D advection-diffusion equation, mesh size =", MX ! Sensitivity-related settings if (sensi /= 0) then - do is=0, NS-1 + do is = 0, NS - 1 plist(is) = int(is, 4) - pbar(is) = p(plist(is)) + pbar(is) = p(plist(is)) end do uS = FN_VCloneVectorArray(NS, u) if (.not. c_associated(uS)) then - write(*,*) 'ERROR: FN_VCloneVectorArray returned NULL' + write (*, *) 'ERROR: FN_VCloneVectorArray returned NULL' stop 1 - endif + end if - do is=0, NS-1 + do is = 0, NS - 1 uiS => FN_VGetVecAtIndexVectorArray(uS, is) call FN_VConst(ZERO, uiS) end do @@ -310,17 +309,17 @@ program main ! create sensitivity fixed point nonlinear solver object if (sensi_meth == CV_SIMULTANEOUS) then - NLSsens => FSUNNonlinSol_FixedPointSens(NS+1, u, 0, ctx) + NLSsens => FSUNNonlinSol_FixedPointSens(NS + 1, u, 0, ctx) else if (sensi_meth == CV_STAGGERED) then NLSsens => FSUNNonlinSol_FixedPointSens(NS, u, 0, ctx) else NLSsens => FSUNNonlinSol_FixedPoint(u, 0, ctx) - endif + end if if (.not. associated(NLSsens)) then - write(*,*) 'ERROR: FSUNNonlinSol_FixedPointSens returned NULL' + write (*, *) 'ERROR: FSUNNonlinSol_FixedPointSens returned NULL' stop 1 - endif + end if ! attach nonlinear solver object to CVode if (sensi_meth == CV_SIMULTANEOUS) then @@ -329,40 +328,40 @@ program main retval = FCVodeSetNonlinearSolverSensStg(cvodes_mem, NLSsens) else retval = FCVodeSetNonlinearSolverSensStg1(cvodes_mem, NLSsens) - endif + end if call check_retval(retval, "FCVodeSetNonlinearSolverSens") - write(*,'(A)',advance="no") "Sensitivity: YES " + write (*, '(A)', advance="no") "Sensitivity: YES " if (sensi_meth == CV_SIMULTANEOUS) then - write(*,'(A)',advance="no") "( SIMULTANEOUS +" + write (*, '(A)', advance="no") "( SIMULTANEOUS +" else if (sensi_meth == CV_STAGGERED) then - write(*,'(A)',advance="no") "( STAGGERED +" + write (*, '(A)', advance="no") "( STAGGERED +" else - write(*,'(A)',advance="no") "( STAGGERED1 +" - endif - endif + write (*, '(A)', advance="no") "( STAGGERED1 +" + end if + end if if (err_con /= 0) then - write(*,'(A)',advance="no") " FULL ERROR CONTROL )" + write (*, '(A)', advance="no") " FULL ERROR CONTROL )" else - write(*,'(A)',advance="no") " PARTIAL ERROR CONTROL )" - endif + write (*, '(A)', advance="no") " PARTIAL ERROR CONTROL )" + end if else - write(*,'(A)') "Sensitivity: NO " + write (*, '(A)') "Sensitivity: NO " - endif + end if ! In loop over output points, call CVode, print results, test for error - write(*,*) "" - write(*,*) "" - write(*,*) "============================================================" - write(*,*) " T Q H NST Max norm " - write(*,*) "============================================================" + write (*, *) "" + write (*, *) "" + write (*, *) "============================================================" + write (*, *) " T Q H NST Max norm " + write (*, *) "============================================================" tout = T1 do iout = 1, NOUT @@ -375,9 +374,9 @@ program main retval = FCVodeGetSens(cvodes_mem, t, uS) call check_retval(retval, "FCVodeGetSens") call PrintOutputS(uS) - endif + end if - write(*,*) "------------------------------------------------------------" + write (*, *) "------------------------------------------------------------" tout = tout + DTOUT end do @@ -389,13 +388,13 @@ program main call FN_VDestroy(u) if (sensi /= 0) then call FN_VDestroyVectorArray(uS, NS) - endif + end if call FCVodeFree(cvodes_mem) retval = FSUNNonlinSolFree(NLS) if (associated(NLSsens)) then retval = FSUNNonlinSolFree(NLSsens) - endif + end if retval = FSUNContext_Free(ctx) @@ -411,14 +410,14 @@ subroutine ProcessArgs(sensi, sensi_meth, err_con) integer(c_int) :: argc character(len=32) :: arg - argc = command_argument_count() - sensi = 0 + argc = command_argument_count() + sensi = 0 sensi_meth = -1 - err_con = 0 + err_con = 0 if (argc < 1) then call WrongArgs() - endif + end if call get_command_argument(1, arg) if (arg == "-nosensi") then @@ -427,13 +426,13 @@ subroutine ProcessArgs(sensi, sensi_meth, err_con) sensi = 1 else call WrongArgs() - endif + end if if (sensi /= 0) then if (argc /= 3) then call WrongArgs() - endif + end if call get_command_argument(2, arg) if (arg == "sim") then @@ -444,7 +443,7 @@ subroutine ProcessArgs(sensi, sensi_meth, err_con) sensi_meth = CV_STAGGERED1 else call WrongArgs() - endif + end if call get_command_argument(3, arg) if (arg == "t") then @@ -453,18 +452,18 @@ subroutine ProcessArgs(sensi, sensi_meth, err_con) err_con = 0 else call WrongArgs() - endif + end if - endif + end if end subroutine ! Print help. subroutine WrongArgs() - write(*,*) "" - write(*,*) "Usage: ./cvsAdvDiff_FSA_non [-nosensi] [-sensi sensi_meth err_con]" - write(*,*) " sensi_meth = sim, stg, or stg1" - write(*,*) " err_con = t or f" - write(*,*) "" + write (*, *) "" + write (*, *) "Usage: ./cvsAdvDiff_FSA_non [-nosensi] [-sensi sensi_meth err_con]" + write (*, *) " sensi_meth = sim, stg, or stg1" + write (*, *) " err_con = t or f" + write (*, *) "" call exit(0) end subroutine @@ -492,10 +491,10 @@ subroutine PrintOutput(cvodes_mem, t, u) retval = FCVodeGetLastOrder(cvodes_mem, qu) retval = FCVodeGetLastStep(cvodes_mem, hu) - write(*,'(1x,es10.3,1x,i2,2x,es10.3,i5)') t, qu, hu, nst + write (*, '(1x,es10.3,1x,i2,2x,es10.3,i5)') t, qu, hu, nst unorm = FN_VMaxNorm(u) - write(*,'(1x,A,es12.4)') " Solution ", unorm + write (*, '(1x,A,es12.4)') " Solution ", unorm end subroutine @@ -512,10 +511,10 @@ subroutine PrintOutputS(uS) uiS => FN_VGetVecAtIndexVectorArray(uS, 0) norm = FN_VMaxNorm(uiS) - write(*,'(1x,A,es12.4)') " Sensitivity 1 ", norm + write (*, '(1x,A,es12.4)') " Sensitivity 1 ", norm uiS => FN_VGetVecAtIndexVectorArray(uS, 1) norm = FN_VMaxNorm(uiS) - write(*,'(1x,A,es12.4)') " Sensitivity 2 ", norm + write (*, '(1x,A,es12.4)') " Sensitivity 2 ", norm end subroutine @@ -550,32 +549,32 @@ subroutine PrintFinalStats(cvodes_mem, sensi, err_con, sensi_meth) retval = FCVodeGetSensNumErrTestFails(cvodes_mem, netfS) else netfS = 0 - endif + end if if (sensi_meth == CV_STAGGERED .or. sensi_meth == CV_STAGGERED1) then retval = FCVodeGetSensNumNonlinSolvIters(cvodes_mem, nniS) retval = FCVodeGetSensNumNonlinSolvConvFails(cvodes_mem, ncfnS) else - nniS = 0 + nniS = 0 ncfnS = 0 - endif + end if - endif + end if - write(*,*) "" - write(*,*) "Final Statistics" - write(*,*) "" - write(*,'(1x,A,i9)') "nst =", nst - write(*,'(1x,A,i9)') "nfe =", nfe - write(*,'(1x,A,i9,A,i9)') "nst =", netf, " nsetups =", nsetups - write(*,'(1x,A,i9,A,i9)') "nni =", nni, " ncfn =", ncfn + write (*, *) "" + write (*, *) "Final Statistics" + write (*, *) "" + write (*, '(1x,A,i9)') "nst =", nst + write (*, '(1x,A,i9)') "nfe =", nfe + write (*, '(1x,A,i9,A,i9)') "nst =", netf, " nsetups =", nsetups + write (*, '(1x,A,i9,A,i9)') "nni =", nni, " ncfn =", ncfn if (sensi /= 0) then - write(*,*) "" - write(*,'(1x,A,i9,A,i9)') "nfSe =", nfSe, " nfeS =", nfeS - write(*,'(1x,A,i9,A,i9)') "netfS =", netfS, " nsetupsS =", nsetupsS - write(*,'(1x,A,i9,A,i9)') "nniS =", nniS, " ncfnS =", ncfnS - endif + write (*, *) "" + write (*, '(1x,A,i9,A,i9)') "nfSe =", nfSe, " nfeS =", nfeS + write (*, '(1x,A,i9,A,i9)') "netfS =", netfS, " nsetupsS =", nsetupsS + write (*, '(1x,A,i9,A,i9)') "nniS =", nniS, " ncfnS =", ncfnS + end if end subroutine @@ -586,7 +585,7 @@ subroutine check_retval(retval, name) integer(c_int) :: retval if (retval /= 0) then - write(*,'(A,A,A)') 'ERROR: ', name,' returned nonzero' + write (*, '(A,A,A)') 'ERROR: ', name, ' returned nonzero' stop 1 end if end subroutine diff --git a/examples/cvodes/F2003_serial/cvs_analytic_fp_f2003.f90 b/examples/cvodes/F2003_serial/cvs_analytic_fp_f2003.f90 index 1c147387af..3087baab20 100644 --- a/examples/cvodes/F2003_serial/cvs_analytic_fp_f2003.f90 +++ b/examples/cvodes/F2003_serial/cvs_analytic_fp_f2003.f90 @@ -33,7 +33,6 @@ module ode_mod !======= Declarations ========= implicit none - ! Since SUNDIALS can be compiled with 32-bit or 64-bit sunindextype ! we set the integer kind used for indices in this example based ! on the the index size SUNDIALS was compiled with so that it works @@ -62,7 +61,7 @@ module ode_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='RhsFn') + result(ierr) bind(C, name='RhsFn') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -87,7 +86,7 @@ integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) & fvec => FN_VGetArrayPointer(sunvec_f) ! fill RHS vector - fvec(1) = lamda*yvec(1) + 1.0/(1.0+tn*tn) - lamda*atan(tn) + fvec(1) = lamda*yvec(1) + 1.0/(1.0 + tn*tn) - lamda*atan(tn) ! return success ierr = 0 @@ -97,7 +96,6 @@ end function RhsFn end module ode_mod - program main !======= Inclusions =========== @@ -136,11 +134,11 @@ program main ! initialize ODE tstart = 0.0d0 - tend = 10.0d0 - tcur = tstart - tout = tstart - dtout = 1.0d0 - nout = ceiling(tend/dtout) + tend = 10.0d0 + tcur = tstart + tout = tstart + dtout = 1.0d0 + nout = ceiling(tend/dtout) ! initialize solution vector yvec(1) = 0.0d0 @@ -148,22 +146,22 @@ program main ! create SUNDIALS N_Vector sunvec_y => FN_VMake_Serial(neq, yvec, ctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! create CVode memory cvodes_mem = FCVodeCreate(CV_ADAMS, ctx) if (.not. c_associated(cvodes_mem)) then - print *, 'ERROR: cvodes_mem = NULL' - stop 1 + print *, 'ERROR: cvodes_mem = NULL' + stop 1 end if ! initialize CVode ierr = FCVodeInit(cvodes_mem, c_funloc(RhsFn), tstart, sunvec_y) if (ierr /= 0) then - print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting' + stop 1 end if ! set relative and absolute tolerances @@ -172,15 +170,15 @@ program main ierr = FCVodeSStolerances(cvodes_mem, rtol, atol) if (ierr /= 0) then - print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting' + stop 1 end if ! create fixed point nonlinear solver object sunnls => FSUNNonlinSol_FixedPoint(sunvec_y, 0, ctx) if (.not. associated(sunnls)) then - print *,'ERROR: sunnls = NULL' - stop 1 + print *, 'ERROR: sunnls = NULL' + stop 1 end if ! attache nonlinear solver object to CVode @@ -197,20 +195,20 @@ program main print *, ' t y ' print *, '----------------------------' print '(2x,2(es12.5,1x))', tcur, yvec(1) - do outstep = 1,nout + do outstep = 1, nout - ! call CVode - tout = min(tout + dtout, tend) - ierr = FCVode(cvodes_mem, tout, sunvec_y, tcur, CV_NORMAL) - if (ierr /= 0) then - print *, 'Error in FCVODES, ierr = ', ierr, '; halting' - stop 1 - endif + ! call CVode + tout = min(tout + dtout, tend) + ierr = FCVode(cvodes_mem, tout, sunvec_y, tcur, CV_NORMAL) + if (ierr /= 0) then + print *, 'Error in FCVODES, ierr = ', ierr, '; halting' + stop 1 + end if - ! output current solution - print '(2x,2(es12.5,1x))', tcur, yvec(1) + ! output current solution + print '(2x,2(es12.5,1x))', tcur, yvec(1) - enddo + end do ! diagnostics output call CVodeStats(cvodes_mem) @@ -223,7 +221,6 @@ program main end program main - ! ---------------------------------------------------------------- ! CVodeStats ! @@ -262,33 +259,33 @@ subroutine CVodeStats(cvodes_mem) ! general solver statistics ierr = FCVodeGetIntegratorStats(cvodes_mem, nsteps, nfevals, nlinsetups, & - netfails, qlast, qcur, hinused, hlast, hcur, tcur) + netfails, qlast, qcur, hinused, hlast, hcur, tcur) if (ierr /= 0) then - print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting' + stop 1 end if ! nonlinear solver statistics ierr = FCVodeGetNonlinSolvStats(cvodes_mem, nniters, nncfails) if (ierr /= 0) then - print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, ' General Solver Stats:' - print '(4x,A,i9)' ,'Total internal steps taken =',nsteps - print '(4x,A,i9)' ,'Total rhs function calls =',nfevals - print '(4x,A,i9)' ,'Num lin solver setup calls =',nlinsetups - print '(4x,A,i9)' ,'Num error test failures =',netfails - print '(4x,A,i9)' ,'Last method order =',qlast - print '(4x,A,i9)' ,'Next method order =',qcur - print '(4x,A,es12.5)','First internal step size =',hinused - print '(4x,A,es12.5)','Last internal step size =',hlast - print '(4x,A,es12.5)','Next internal step size =',hcur - print '(4x,A,es12.5)','Current internal time =',tcur - print '(4x,A,i9)' ,'Num nonlinear solver iters =',nniters - print '(4x,A,i9)' ,'Num nonlinear solver fails =',nncfails + print '(4x,A,i9)', 'Total internal steps taken =', nsteps + print '(4x,A,i9)', 'Total rhs function calls =', nfevals + print '(4x,A,i9)', 'Num lin solver setup calls =', nlinsetups + print '(4x,A,i9)', 'Num error test failures =', netfails + print '(4x,A,i9)', 'Last method order =', qlast + print '(4x,A,i9)', 'Next method order =', qcur + print '(4x,A,es12.5)', 'First internal step size =', hinused + print '(4x,A,es12.5)', 'Last internal step size =', hlast + print '(4x,A,es12.5)', 'Next internal step size =', hcur + print '(4x,A,es12.5)', 'Current internal time =', tcur + print '(4x,A,i9)', 'Num nonlinear solver iters =', nniters + print '(4x,A,i9)', 'Num nonlinear solver fails =', nncfails print *, ' ' return diff --git a/examples/ida/F2003_openmp/idaHeat2D_kry_omp_f2003.f90 b/examples/ida/F2003_openmp/idaHeat2D_kry_omp_f2003.f90 index 3e83d622e6..3dc08bc7e9 100644 --- a/examples/ida/F2003_openmp/idaHeat2D_kry_omp_f2003.f90 +++ b/examples/ida/F2003_openmp/idaHeat2D_kry_omp_f2003.f90 @@ -46,13 +46,13 @@ module idaHeat2DKryOMP_mod !======= Declarations ========= implicit none - integer(c_int), parameter :: nout = 11 - integer(c_int), parameter :: mgrid = 100 - integer(c_int64_t), parameter :: neq = mgrid*mgrid + integer(c_int), parameter :: nout = 11 + integer(c_int), parameter :: mgrid = 100 + integer(c_int64_t), parameter :: neq = mgrid*mgrid real(c_double) :: dx real(c_double) :: coeff - real(c_double) :: pp(mgrid,mgrid) + real(c_double) :: pp(mgrid, mgrid) contains @@ -65,7 +65,7 @@ module idaHeat2DKryOMP_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) & - result(ierr) bind(C,name='resHeat') + result(ierr) bind(C, name='resHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -78,12 +78,12 @@ integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_up ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(mgrid,mgrid) :: u(:,:) - real(c_double), pointer, dimension(mgrid,mgrid) :: up(:,:) - real(c_double), pointer, dimension(mgrid,mgrid) :: r(:,:) + real(c_double), pointer, dimension(mgrid, mgrid) :: u(:, :) + real(c_double), pointer, dimension(mgrid, mgrid) :: up(:, :) + real(c_double), pointer, dimension(mgrid, mgrid) :: r(:, :) ! local variables integer(c_int64_t) :: i, j @@ -91,9 +91,9 @@ integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) !======= Internals ============ ! get data arrays from SUNDIALS vectors - u(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) + u(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up) - r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) + r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) ! Initialize r to u, to take care of boundary equations !$omp parallel @@ -103,10 +103,10 @@ integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) ! Loop over interior points; set res = up - (central difference) !$omp do collapse(2) private(i,j) - do j = 2,mgrid-1 - do i = 2,mgrid-1 - r(i,j) = up(i,j) - coeff*( u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1) - 4.d0*u(i,j)) - end do + do j = 2, mgrid - 1 + do i = 2, mgrid - 1 + r(i, j) = up(i, j) - coeff*(u(i - 1, j) + u(i + 1, j) + u(i, j - 1) + u(i, j + 1) - 4.d0*u(i, j)) + end do end do !$omp end do !$omp end parallel @@ -127,7 +127,7 @@ end function resHeat ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_data) & - result(ierr) bind(C,name='PSetupHeat') + result(ierr) bind(C, name='PSetupHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -141,7 +141,7 @@ integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_da type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_up ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector - type(c_ptr), value :: prec_data ! preconditioner data + type(c_ptr), value :: prec_data ! preconditioner data ! local variables real(c_double) :: pelinv @@ -156,7 +156,7 @@ integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_da ! set the interior points to the correct value for preconditioning !$omp parallel workshare - pp(2:mgrid-1, 2:mgrid-1) = pelinv + pp(2:mgrid - 1, 2:mgrid - 1) = pelinv !$omp end parallel workshare ! return success @@ -175,7 +175,7 @@ end function PSetupHeat ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, & - sunvec_sol, cj, delta, prec_data) result(ierr) bind(C,name='PSolveHeat') + sunvec_sol, cj, delta, prec_data) result(ierr) bind(C, name='PSolveHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -192,11 +192,11 @@ integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, type(N_Vector) :: sunvec_r ! residual N_Vector type(N_Vector) :: sunvec_rhs ! rhs N_Vector type(N_Vector) :: sunvec_sol ! solution N_Vector - type(c_ptr), value :: prec_data ! preconditioner data + type(c_ptr), value :: prec_data ! preconditioner data ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(mgrid,mgrid) :: rhs(:,:) - real(c_double), pointer, dimension(mgrid,mgrid) :: sol(:,:) + real(c_double), pointer, dimension(mgrid, mgrid) :: rhs(:, :) + real(c_double), pointer, dimension(mgrid, mgrid) :: sol(:, :) !======= Internals ============ @@ -206,7 +206,7 @@ integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, ! Apply preconditioner to rhs to create sol !$omp parallel workshare - sol = rhs * pp + sol = rhs*pp !$omp end parallel workshare ! return success @@ -219,7 +219,6 @@ end function PSolveHeat end module idaHeat2DKryOMP_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -238,11 +237,11 @@ program main integer(c_int) :: retval, iout integer(c_long) :: netf(1), ncfn(1), ncfl(1) - type(N_Vector), pointer :: sunvec_u ! sundials solution vector - type(N_Vector), pointer :: sunvec_up ! sundials derivative vector - type(N_Vector), pointer :: sunvec_c ! sundials constraints vector - type(N_Vector), pointer :: sunvec_r ! sundials residual vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(N_Vector), pointer :: sunvec_u ! sundials solution vector + type(N_Vector), pointer :: sunvec_up ! sundials derivative vector + type(N_Vector), pointer :: sunvec_c ! sundials constraints vector + type(N_Vector), pointer :: sunvec_r ! sundials residual vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: ida_mem ! IDA memory type(c_ptr) :: sunctx ! sundials simulation context @@ -250,7 +249,7 @@ program main character(len=32) :: arg ! input arg ! solution, residual and constraints vectors, mgrid is set in the idaHeat2DKryOMP_mod module - real(c_double), dimension(mgrid,mgrid) :: uu, up, res, constraints + real(c_double), dimension(mgrid, mgrid) :: uu, up, res, constraints !======= Internals ============ retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) @@ -258,40 +257,40 @@ program main ! get the number of threads passed in as a command line argument (if applicable) nargs = command_argument_count() if (nargs > 0) then - call get_command_argument(1, arg, length, status) - read(arg,*) nthreads + call get_command_argument(1, arg, length, status) + read (arg, *) nthreads else - nthreads = 6 - endif + nthreads = 6 + end if call omp_set_num_threads(nthreads) ! Assign parameters in idaHeat2DKryOMP_mod - dx = 1.d0/(mgrid-1) - coeff = 1.d0/(dx * dx) + dx = 1.d0/(mgrid - 1) + coeff = 1.d0/(dx*dx) ! create N_Vectors sunvec_u => FN_VMake_OpenMP(neq, uu, nthreads, sunctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_up => FN_VMake_OpenMP(neq, up, nthreads, sunctx) if (.not. associated(sunvec_up)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_r => FN_VMake_OpenMP(neq, res, nthreads, sunctx) if (.not. associated(sunvec_r)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_c => FN_VMake_OpenMP(neq, constraints, nthreads, sunctx) if (.not. associated(sunvec_c)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! Initialize solution vectors @@ -301,64 +300,64 @@ program main constraints = 1.d0 ! Assign various parameters - t0 = 0.d0 - t1 = 0.01d0 + t0 = 0.d0 + t1 = 0.01d0 rtol = 0.d0 atol = 1.d-3 ! Call FIDACreate and FIDAInit to initialize solution ida_mem = FIDACreate(sunctx) if (.not. c_associated(ida_mem)) then - print *, 'ERROR: ida_mem = NULL' - stop 1 + print *, 'ERROR: ida_mem = NULL' + stop 1 end if retval = FIDASetConstraints(ida_mem, sunvec_c) if (retval /= 0) then - print *, 'Error in FIDASetConstraints, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetConstraints, retval = ', retval, '; halting' + stop 1 end if retval = FIDAInit(ida_mem, c_funloc(resHeat), t0, sunvec_u, sunvec_up) if (retval /= 0) then - print *, 'Error in FIDAInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAInit, retval = ', retval, '; halting' + stop 1 end if retval = FIDASStolerances(ida_mem, rtol, atol) if (retval /= 0) then - print *, 'Error in FIDASStolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASStolerances, retval = ', retval, '; halting' + stop 1 end if ! Create the linear solver SUNLinSol_SPGMR with left preconditioning ! and the default Krylov dimension sunlinsol_LS => FSUNLinSol_SPGMR(sunvec_u, SUN_PREC_LEFT, 0, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! IDA recommends allowing up to 5 restarts (default is 0) retval = FSUNLinSol_SPGMRSetMaxRestarts(sunlinsol_LS, 5) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' + stop 1 end if ! Attach the linear solver (will NULL SUNMatrix object) sunmat_A => null() retval = FIDASetLinearSolver(ida_mem, sunlinsol_LS, sunmat_A) if (retval /= 0) then - print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the preconditioner solve and setup functions */ retval = FIDASetPreconditioner(ida_mem, c_funloc(PsetupHeat), c_funloc(PsolveHeat)) if (retval /= 0) then - print *, 'Error in FIDASetPreconditioner, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetPreconditioner, retval = ', retval, '; halting' + stop 1 end if ! Print output heading @@ -382,33 +381,33 @@ program main ! Loop over output times, call IDASolve, and print results tout = t1 - do iout = 1,NOUT - retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) - if (retval < 0) then - print *, 'Error in FIDASolve, retval = ', retval, '; halting' - stop 1 - end if - call PrintOutput(ida_mem, tret(1), uu) - tout = 2.d0*tout + do iout = 1, NOUT + retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) + if (retval < 0) then + print *, 'Error in FIDASolve, retval = ', retval, '; halting' + stop 1 + end if + call PrintOutput(ida_mem, tret(1), uu) + tout = 2.d0*tout end do ! Print remaining counters retval = FIDAGetNumErrTestFails(ida_mem, netf) if (retval /= 0) then - print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvConvFails(ida_mem, ncfn) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinConvFails(ida_mem, ncfl) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if print *, " " @@ -428,14 +427,14 @@ program main retval = FIDAReInit(ida_mem, t0, sunvec_u, sunvec_up) if (retval /= 0) then - print *, 'Error in FIDAReInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAReInit, retval = ', retval, '; halting' + stop 1 end if retval = FSUNLinSol_SPGMRSetGSType(sunlinsol_LS, SUN_CLASSICAL_GS) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval, '; halting' + stop 1 end if ! Print case number, output table heading, and initial line of table @@ -451,34 +450,34 @@ program main ! Loop over output times, call IDASolve, and print results tout = t1 - do iout = 1,NOUT - retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) - if (retval < 0) then - print *, 'Error in FIDASolve, retval = ', retval, '; halting' - stop 1 - end if - call PrintOutput(ida_mem, tret(1), uu) - tout = 2.d0*tout + do iout = 1, NOUT + retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) + if (retval < 0) then + print *, 'Error in FIDASolve, retval = ', retval, '; halting' + stop 1 + end if + call PrintOutput(ida_mem, tret(1), uu) + tout = 2.d0*tout end do ! Print remaining counters retval = FIDAGetNumErrTestFails(ida_mem, netf) if (retval /= 0) then - print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvConvFails(ida_mem, ncfn) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinConvFails(ida_mem, ncfl) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if print *, " " @@ -498,7 +497,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! SetInitialProfile: routine to initialize u and up vectors. ! ---------------------------------------------------------------- @@ -517,9 +515,9 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) type(N_Vector) :: sunvec_r ! residual N_Vector ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(mgrid,mgrid) :: uu(:,:) - real(c_double), pointer, dimension(mgrid,mgrid) :: up(:,:) - real(c_double), pointer, dimension(mgrid,mgrid) :: r(:,:) + real(c_double), pointer, dimension(mgrid, mgrid) :: uu(:, :) + real(c_double), pointer, dimension(mgrid, mgrid) :: up(:, :) + real(c_double), pointer, dimension(mgrid, mgrid) :: r(:, :) ! local variables integer(c_int64_t) :: i, j @@ -531,18 +529,18 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) ! get data arrays from SUNDIALS vectors uu(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up) - r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) + r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) !======= Internals ============ ! Initialize uu on all grid points !$omp parallel do collapse(2) private(yfact,xfact,i,j) - do j = 1,mgrid - do i = 1,mgrid - yfact = dx * (j-1) - xfact = dx * (i-1) - uu(i,j) = 16.d0 * xfact * (1.d0 - xfact) * yfact * (1.d0 - yfact) - end do + do j = 1, mgrid + do i = 1, mgrid + yfact = dx*(j - 1) + xfact = dx*(i - 1) + uu(i, j) = 16.d0*xfact*(1.d0 - xfact)*yfact*(1.d0 - yfact) + end do end do !$omp end parallel do @@ -550,7 +548,7 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) up = 0.d0 ! resHeat sets res to negative of ODE RHS values at interior points - retval = resHeat(0.d0, sunvec_u, sunvec_up, sunvec_r, C_NULL_PTR) + retval = resHeat(0.d0, sunvec_u, sunvec_up, sunvec_r, c_null_ptr) ! Copy -r into up to get correct interior initial up values !$omp parallel workshare @@ -558,16 +556,15 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) !$omp end parallel workshare ! Set up at boundary points to zero - up(1,:) = 0.d0 - up(mgrid,:) = 0.d0 - up(:,1) = 0.d0 - up(:,mgrid) = 0.d0 + up(1, :) = 0.d0 + up(mgrid, :) = 0.d0 + up(:, 1) = 0.d0 + up(:, mgrid) = 0.d0 return end subroutine SetInitialProfile ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -590,11 +587,11 @@ subroutine PrintHeader(rtol, atol) print *, " Discretized heat equation on 2D unit square." print *, " Zero boundary conditions, polynomial initial conditions." print '(2(a,i4),a,i8)', " Mesh dimensions: ", mgrid, " x ", mgrid, & - " Total system size: ", neq + " Total system size: ", neq print *, " " print *, " Number of OpenMP threads = ", omp_get_max_threads() print *, " " - print '(2(a,es8.1))', "Tolerance parameters: rtol = ", rtol," atol = ", atol + print '(2(a,es8.1))', "Tolerance parameters: rtol = ", rtol, " atol = ", atol print *, "Constraints set to force all solution components >= 0." print *, "Linear solver: SPGMR, preconditioner using diagonal elements." @@ -602,7 +599,6 @@ subroutine PrintHeader(rtol, atol) end subroutine PrintHeader ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -618,7 +614,7 @@ subroutine PrintOutput(ida_mem, t, uu) ! calling variable type(c_ptr) :: ida_mem - real(c_double) :: t, uu(mgrid,mgrid) + real(c_double) :: t, uu(mgrid, mgrid) ! internal variables integer(c_int) :: retval, kused(1) @@ -631,67 +627,66 @@ subroutine PrintOutput(ida_mem, t, uu) retval = FIDAGetLastOrder(ida_mem, kused) if (retval /= 0) then - print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumSteps(ida_mem, nst) if (retval /= 0) then - print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvIters(ida_mem, nni) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumResEvals(ida_mem, nre) if (retval /= 0) then - print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetLastStep(ida_mem, hused) if (retval /= 0) then - print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumJtimesEvals(ida_mem, nje) if (retval /= 0) then - print *, 'Error in FIDAGetNumJtimesEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumJtimesEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinIters(ida_mem, nli) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinIters, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinResEvals(ida_mem, nreLS) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumPrecEvals(ida_mem, npe) if (retval /= 0) then - print *, 'Error in FIDAGetNumPrecEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumPrecEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumPrecSolves(ida_mem, nps) if (retval /= 0) then - print *, 'Error in FIDAGetNumPrecSolves, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumPrecSolves, retval = ', retval, '; halting' + stop 1 end if - print '(f5.2,1x,es13.5,4x,i1,2x,3(i3,2x),2(i4,2x),es9.2,2x,2(i3,1x))', & - t, umax, kused, nst, nni, nje, nre, nreLS, hused(1), npe, nps + t, umax, kused, nst, nni, nje, nre, nreLS, hused(1), npe, nps end subroutine PrintOutput ! ---------------------------------------------------------------- diff --git a/examples/ida/F2003_parallel/ida_heat2D_kry_bbd_f2003.f90 b/examples/ida/F2003_parallel/ida_heat2D_kry_bbd_f2003.f90 index 0f76650345..de8b11e835 100644 --- a/examples/ida/F2003_parallel/ida_heat2D_kry_bbd_f2003.f90 +++ b/examples/ida/F2003_parallel/ida_heat2D_kry_bbd_f2003.f90 @@ -82,7 +82,7 @@ module Heat2DKryBBD_mod integer, target :: comm ! communicator object integer :: myid ! MPI process ID integer :: nprocs ! total number of MPI processes - logical :: HaveNbor(2,2) ! flags denoting neighbor on boundary + logical :: HaveNbor(2, 2) ! flags denoting neighbor on boundary real(c_double), dimension(:), allocatable :: Erecv ! receive buffers for neighbor exchange real(c_double), dimension(:), allocatable :: Wrecv real(c_double), dimension(:), allocatable :: Nrecv @@ -136,18 +136,17 @@ subroutine InitHeat2DData() myid = 0 nprocs = 0 HaveNbor = .false. - if (allocated(Erecv)) deallocate(Erecv) - if (allocated(Wrecv)) deallocate(Wrecv) - if (allocated(Nrecv)) deallocate(Nrecv) - if (allocated(Srecv)) deallocate(Srecv) - if (allocated(Esend)) deallocate(Esend) - if (allocated(Wsend)) deallocate(Wsend) - if (allocated(Nsend)) deallocate(Nsend) - if (allocated(Ssend)) deallocate(Ssend) + if (allocated(Erecv)) deallocate (Erecv) + if (allocated(Wrecv)) deallocate (Wrecv) + if (allocated(Nrecv)) deallocate (Nrecv) + if (allocated(Srecv)) deallocate (Srecv) + if (allocated(Esend)) deallocate (Esend) + if (allocated(Wsend)) deallocate (Wsend) + if (allocated(Nsend)) deallocate (Nsend) + if (allocated(Ssend)) deallocate (Ssend) end subroutine InitHeat2DData ! -------------------------------------------------------------- - ! -------------------------------------------------------------- ! Set up parallel decomposition ! -------------------------------------------------------------- @@ -164,61 +163,61 @@ subroutine SetupDecomp(ierr) dims = (/0, 0/) call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = " , ierr - return + write (0, *) "Error in MPI_Comm_size = ", ierr + return end if call MPI_Dims_create(nprocs, 2, dims, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Dims_create = " , ierr - return + write (0, *) "Error in MPI_Dims_create = ", ierr + return end if ! set up 2D Cartesian communicator periods = (/0, 0/) call MPI_Cart_create(MPI_COMM_WORLD, 2, dims, periods, 0, comm, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_create = " , ierr - return + write (0, *) "Error in MPI_Cart_create = ", ierr + return end if call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = " , ierr - return + write (0, *) "Error in MPI_Comm_rank = ", ierr + return end if ! determine local extents call MPI_Cart_get(comm, 2, dims, periods, coords, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_get = " , ierr - return + write (0, *) "Error in MPI_Cart_get = ", ierr + return end if is = nx*coords(1)/dims(1) + 1 - ie = nx*(coords(1)+1)/dims(1) + ie = nx*(coords(1) + 1)/dims(1) js = ny*coords(2)/dims(2) + 1 - je = ny*(coords(2)+1)/dims(2) - nxl = ie-is+1 - nyl = je-js+1 + je = ny*(coords(2) + 1)/dims(2) + nxl = ie - is + 1 + nyl = je - js + 1 ! determine if I have neighbors, and allocate exchange buffers - HaveNbor(1,1) = (is /= 1) - HaveNbor(1,2) = (ie /= nx) - HaveNbor(2,1) = (js /= 1) - HaveNbor(2,2) = (je /= ny) - if (HaveNbor(1,1)) then - allocate(Wrecv(nyl)) - allocate(Wsend(nyl)) + HaveNbor(1, 1) = (is /= 1) + HaveNbor(1, 2) = (ie /= nx) + HaveNbor(2, 1) = (js /= 1) + HaveNbor(2, 2) = (je /= ny) + if (HaveNbor(1, 1)) then + allocate (Wrecv(nyl)) + allocate (Wsend(nyl)) end if - if (HaveNbor(1,2)) then - allocate(Erecv(nyl)) - allocate(Esend(nyl)) + if (HaveNbor(1, 2)) then + allocate (Erecv(nyl)) + allocate (Esend(nyl)) end if - if (HaveNbor(2,1)) then - allocate(Srecv(nxl)) - allocate(Ssend(nxl)) + if (HaveNbor(2, 1)) then + allocate (Srecv(nxl)) + allocate (Ssend(nxl)) end if - if (HaveNbor(2,2)) then - allocate(Nrecv(nxl)) - allocate(Nsend(nxl)) + if (HaveNbor(2, 2)) then + allocate (Nrecv(nxl)) + allocate (Nsend(nxl)) end if ierr = 0 ! return with success flag @@ -232,21 +231,21 @@ end subroutine SetupDecomp subroutine FreeHeat2DData(ierr) implicit none integer, intent(out) :: ierr - if (allocated(Wrecv)) deallocate(Wrecv) - if (allocated(Wsend)) deallocate(Wsend) - if (allocated(Erecv)) deallocate(Erecv) - if (allocated(Esend)) deallocate(Esend) - if (allocated(Srecv)) deallocate(Srecv) - if (allocated(Ssend)) deallocate(Ssend) - if (allocated(Nrecv)) deallocate(Nrecv) - if (allocated(Nsend)) deallocate(Nsend) + if (allocated(Wrecv)) deallocate (Wrecv) + if (allocated(Wsend)) deallocate (Wsend) + if (allocated(Erecv)) deallocate (Erecv) + if (allocated(Esend)) deallocate (Esend) + if (allocated(Srecv)) deallocate (Srecv) + if (allocated(Ssend)) deallocate (Ssend) + if (allocated(Nrecv)) deallocate (Nrecv) + if (allocated(Nsend)) deallocate (Nsend) ierr = 0 ! return with success flag return end subroutine FreeHeat2DData ! -------------------------------------------------------------- subroutine InitProfile(sunvec_y, sunvec_ydot, sunvec_id, & - sunvec_res, sunvec_c, ierr) + sunvec_res, sunvec_c, ierr) use fnvector_parallel_mod implicit none type(N_Vector), pointer, intent(inout) :: sunvec_y @@ -255,7 +254,7 @@ subroutine InitProfile(sunvec_y, sunvec_ydot, sunvec_id, & type(N_Vector), pointer, intent(inout) :: sunvec_res type(N_Vector), pointer, intent(inout) :: sunvec_c integer(c_int), intent(in) :: ierr - real(c_double), pointer, dimension(nxl,nyl) :: y(:,:), ydot(:,:), id(:,:), res(:,:), cstr(:,:) + real(c_double), pointer, dimension(nxl, nyl) :: y(:, :), ydot(:, :), id(:, :), res(:, :), cstr(:, :) real(c_double) :: xreal, yreal integer(c_int) :: retval type(c_ptr) :: user_data @@ -266,42 +265,42 @@ subroutine InitProfile(sunvec_y, sunvec_ydot, sunvec_id, & ! Create solution vector, point at its data, and set initial condition N = nxl*nyl Ntot = nx*ny - sunvec_y => FN_VNew_Parallel(comm, N, Ntot, sunctx) + sunvec_y => FN_VNew_Parallel(comm, N, Ntot, sunctx) sunvec_ydot => FN_VNew_Parallel(comm, N, Ntot, sunctx) - sunvec_id => FN_VNew_Parallel(comm, N, Ntot, sunctx) - sunvec_res => FN_VNew_Parallel(comm, N, Ntot, sunctx) - sunvec_c => FN_VNew_Parallel(comm, N, Ntot, sunctx) - y(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_y) - ydot(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_ydot) - id(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_id) - res(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_res) - cstr(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_c) + sunvec_id => FN_VNew_Parallel(comm, N, Ntot, sunctx) + sunvec_res => FN_VNew_Parallel(comm, N, Ntot, sunctx) + sunvec_c => FN_VNew_Parallel(comm, N, Ntot, sunctx) + y(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_y) + ydot(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_ydot) + id(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_id) + res(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_res) + cstr(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_c) id = 1.d0 - do i = 1,nxl - xreal = dx*dble(is+i-2) - do j = 1,nyl - yreal = dy*dble(js+j-2) - if (.not. HaveNbor(1,1) .and. i == 1) then - id(i,j) = 0.d0 - end if - if (.not. HaveNbor(1,2) .and. i == nxl) then - id(i,j) = 0.d0 - end if - if (.not. HaveNbor(2,1) .and. j == 1) then - id(i,j) = 0.d0 - end if - if (.not. HaveNbor(2,2) .and. j == nyl) then - id(i,j) = 0.d0 - end if - y(i,j) = 16.d0*xreal*(1.d0-xreal)*yreal*(1.d0-yreal) - end do + do i = 1, nxl + xreal = dx*dble(is + i - 2) + do j = 1, nyl + yreal = dy*dble(js + j - 2) + if (.not. HaveNbor(1, 1) .and. i == 1) then + id(i, j) = 0.d0 + end if + if (.not. HaveNbor(1, 2) .and. i == nxl) then + id(i, j) = 0.d0 + end if + if (.not. HaveNbor(2, 1) .and. j == 1) then + id(i, j) = 0.d0 + end if + if (.not. HaveNbor(2, 2) .and. j == nyl) then + id(i, j) = 0.d0 + end if + y(i, j) = 16.d0*xreal*(1.d0 - xreal)*yreal*(1.d0 - yreal) + end do end do ydot = 0.d0 cstr = 1.d0 retval = resfn(0.d0, sunvec_y, sunvec_ydot, sunvec_res, user_data) if (retval /= 0) then - print *, "Error: resfn in InitProfile returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: resfn in InitProfile returned ", retval + call MPI_Abort(comm, 1, ierr) end if ydot = -1.d0*res @@ -320,68 +319,68 @@ subroutine getStats(ida_mem, retval, ierr) implicit none ! calling variables - type(c_ptr), intent(in) :: ida_mem + type(c_ptr), intent(in) :: ida_mem integer(c_int), intent(in) :: ierr integer(c_int), intent(out) :: retval retval = FIDAGetLastOrder(ida_mem, k) if (retval /= 0) then - print *, "Error: FIDAGetLastOrder returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetLastOrder returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetNumSteps(ida_mem, nst) if (retval /= 0) then - print *, "Error: FIDAGetNumSteps returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetNumSteps returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetNumNonlinSolvIters(ida_mem, nni) if (retval /= 0) then - print *, "Error: FIDAGetNumNonlinSolvIters returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetNumNonlinSolvIters returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetNumLinIters(ida_mem, nli) if (retval /= 0) then - print *, "Error: FIDAGetNumLinIters returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetNumLinIters returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetNumResEvals(ida_mem, nre) if (retval /= 0) then - print *, "Error: FIDAGetNumResEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetNumResEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetNumLinResEvals(ida_mem, nreLS) if (retval /= 0) then - print *, "Error: FIDAGetNumLinResEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetNumLinResEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDABBDPrecGetNumGfnEvals(ida_mem, nge) if (retval /= 0) then - print *, "Error: FIDABBDPrecGetNumGfnEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDABBDPrecGetNumGfnEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetLastStep(ida_mem, h) if (retval /= 0) then - print *, "Error: FIDAGetLastStep returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetLastStep returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetNumPrecEvals(ida_mem, npre) if (retval /= 0) then - print *, "Error: FIDAGetNumPrecEvals returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetNumPrecEvals returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDAGetNumPrecSolves(ida_mem, npsol) if (retval /= 0) then - print *, "Error: FIDAGetNumPrecSolves returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAGetNumPrecSolves returned ", retval + call MPI_Abort(comm, 1, ierr) end if end subroutine getStats @@ -391,7 +390,7 @@ end subroutine getStats ! DAE residual function r(t,y). ! ---------------------------------------------------------------- integer(c_int) function resfn(t, sunvec_y, sunvec_ydot, sunvec_res, & - user_data) result(retval) bind(C) + user_data) result(retval) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -405,21 +404,21 @@ integer(c_int) function resfn(t, sunvec_y, sunvec_ydot, sunvec_res, & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector type(N_Vector) :: sunvec_res ! residual N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data !======= Internals ============ ! Exchange boundary data with neighbors retval = Exchange(N, t, sunvec_y, sunvec_ydot, sunvec_res, user_data) if (retval /= MPI_SUCCESS) then - write(0,*) "Error in Exchange = " , retval - return + write (0, *) "Error in Exchange = ", retval + return end if retval = LocalFn(N, t, sunvec_y, sunvec_ydot, sunvec_res, user_data) if (retval /= MPI_SUCCESS) then - write(0,*) "Error in LocalFn = " , retval - return + write (0, *) "Error in LocalFn = ", retval + return end if retval = 0 ! Return with success @@ -427,12 +426,11 @@ integer(c_int) function resfn(t, sunvec_y, sunvec_ydot, sunvec_res, & end function resfn ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Perform neighbor exchange (Communication function) ! ---------------------------------------------------------------- integer(c_int) function Exchange(Nloc, t, sunvec_y, sunvec_ydot, & - sunvec_g, user_data) result(ierr) bind(C) + sunvec_g, user_data) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -443,188 +441,188 @@ integer(c_int) function Exchange(Nloc, t, sunvec_y, sunvec_ydot, & ! calling variables integer(c_int64_t), value :: Nloc - real(c_double), value :: t ! current time + real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector type(N_Vector) :: sunvec_g ! evaluated N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data - real(c_double), pointer, dimension(nxl,nyl) :: y(:,:) - integer :: reqSW, reqSE, reqSS, reqSN, reqRW, reqRE, reqRS, reqRN; + real(c_double), pointer, dimension(nxl, nyl) :: y(:, :) + integer :: reqSW, reqSE, reqSS, reqSN, reqRW, reqRE, reqRS, reqRN; integer :: stat(MPI_STATUS_SIZE) integer :: i, ipW, ipE, ipS, ipN integer :: coords(2), dims(2), periods(2), nbcoords(2) ! internals - y(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_y) + y(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_y) ! MPI neighborhood information call MPI_Cart_get(comm, 2, dims, periods, coords, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_get = ", ierr - return + write (0, *) "Error in MPI_Cart_get = ", ierr + return end if - if (HaveNbor(1,1)) then - nbcoords = (/ coords(1)-1, coords(2) /) - call MPI_Cart_rank(comm, nbcoords, ipW, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - end if + if (HaveNbor(1, 1)) then + nbcoords = (/coords(1) - 1, coords(2)/) + call MPI_Cart_rank(comm, nbcoords, ipW, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if end if - if (HaveNbor(1,2)) then - nbcoords = (/ coords(1)+1, coords(2) /) - call MPI_Cart_rank(comm, nbcoords, ipE, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - end if + if (HaveNbor(1, 2)) then + nbcoords = (/coords(1) + 1, coords(2)/) + call MPI_Cart_rank(comm, nbcoords, ipE, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if end if - if (HaveNbor(2,1)) then - nbcoords = (/ coords(1), coords(2)-1 /) - call MPI_Cart_rank(comm, nbcoords, ipS, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - end if + if (HaveNbor(2, 1)) then + nbcoords = (/coords(1), coords(2) - 1/) + call MPI_Cart_rank(comm, nbcoords, ipS, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if end if - if (HaveNbor(2,2)) then - nbcoords = (/ coords(1), coords(2)+1 /) - call MPI_Cart_rank(comm, nbcoords, ipN, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Cart_rank = ", ierr - return - end if + if (HaveNbor(2, 2)) then + nbcoords = (/coords(1), coords(2) + 1/) + call MPI_Cart_rank(comm, nbcoords, ipN, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Cart_rank = ", ierr + return + end if end if ! open Irecv buffers - if (HaveNbor(1,1)) then - call MPI_Irecv(Wrecv, nyl, MPI_DOUBLE_PRECISION, ipW, & - MPI_ANY_TAG, comm, reqRW, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - end if + if (HaveNbor(1, 1)) then + call MPI_Irecv(Wrecv, nyl, MPI_DOUBLE_PRECISION, ipW, & + MPI_ANY_TAG, comm, reqRW, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if end if - if (HaveNbor(1,2)) then - call MPI_Irecv(Erecv, nyl, MPI_DOUBLE_PRECISION, ipE, & - MPI_ANY_TAG, comm, reqRE, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - end if + if (HaveNbor(1, 2)) then + call MPI_Irecv(Erecv, nyl, MPI_DOUBLE_PRECISION, ipE, & + MPI_ANY_TAG, comm, reqRE, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if end if - if (HaveNbor(2,1)) then - call MPI_Irecv(Srecv, nxl, MPI_DOUBLE_PRECISION, ipS, & - MPI_ANY_TAG, comm, reqRS, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - end if + if (HaveNbor(2, 1)) then + call MPI_Irecv(Srecv, nxl, MPI_DOUBLE_PRECISION, ipS, & + MPI_ANY_TAG, comm, reqRS, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if end if - if (HaveNbor(2,2)) then - call MPI_Irecv(Nrecv, nxl, MPI_DOUBLE_PRECISION, ipN, & - MPI_ANY_TAG, comm, reqRN, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Irecv = ", ierr - return - end if + if (HaveNbor(2, 2)) then + call MPI_Irecv(Nrecv, nxl, MPI_DOUBLE_PRECISION, ipN, & + MPI_ANY_TAG, comm, reqRN, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Irecv = ", ierr + return + end if end if ! send data - if (HaveNbor(1,1)) then - do i=1,nyl - Wsend(i) = y(1,i) - end do - call MPI_Isend(Wsend, nyl, MPI_DOUBLE_PRECISION, ipW, 0, & - comm, reqSW, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - end if + if (HaveNbor(1, 1)) then + do i = 1, nyl + Wsend(i) = y(1, i) + end do + call MPI_Isend(Wsend, nyl, MPI_DOUBLE_PRECISION, ipW, 0, & + comm, reqSW, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if end if - if (HaveNbor(1,2)) then - do i=1,nyl - Esend(i) = y(nxl,i) - end do - call MPI_Isend(Esend, nyl, MPI_DOUBLE_PRECISION, ipE, 1, & - comm, reqSE, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - end if + if (HaveNbor(1, 2)) then + do i = 1, nyl + Esend(i) = y(nxl, i) + end do + call MPI_Isend(Esend, nyl, MPI_DOUBLE_PRECISION, ipE, 1, & + comm, reqSE, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if end if - if (HaveNbor(2,1)) then - do i=1,nxl - Ssend(i) = y(i,1) - end do - call MPI_Isend(Ssend, nxl, MPI_DOUBLE_PRECISION, ipS, 2, & - comm, reqSS, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - end if + if (HaveNbor(2, 1)) then + do i = 1, nxl + Ssend(i) = y(i, 1) + end do + call MPI_Isend(Ssend, nxl, MPI_DOUBLE_PRECISION, ipS, 2, & + comm, reqSS, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if end if - if (HaveNbor(2,2)) then - do i=1,nxl - Nsend(i) = y(i,nyl) - end do - call MPI_Isend(Nsend, nxl, MPI_DOUBLE_PRECISION, ipN, 3, & - comm, reqSN, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Isend = ", ierr - return - end if + if (HaveNbor(2, 2)) then + do i = 1, nxl + Nsend(i) = y(i, nyl) + end do + call MPI_Isend(Nsend, nxl, MPI_DOUBLE_PRECISION, ipN, 3, & + comm, reqSN, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Isend = ", ierr + return + end if end if ! wait for messages to finish - if (HaveNbor(1,1)) then - call MPI_Wait(reqRW, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if - call MPI_Wait(reqSW, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if + if (HaveNbor(1, 1)) then + call MPI_Wait(reqRW, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSW, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if end if - if (HaveNbor(1,2)) then - call MPI_Wait(reqRE, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if - call MPI_Wait(reqSE, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if + if (HaveNbor(1, 2)) then + call MPI_Wait(reqRE, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSE, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if end if - if (HaveNbor(2,1)) then - call MPI_Wait(reqRS, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if - call MPI_Wait(reqSS, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if + if (HaveNbor(2, 1)) then + call MPI_Wait(reqRS, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSS, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if end if - if (HaveNbor(2,2)) then - call MPI_Wait(reqRN, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if - call MPI_Wait(reqSN, stat, ierr) - if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Wait = ", ierr - return - end if + if (HaveNbor(2, 2)) then + call MPI_Wait(reqRN, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if + call MPI_Wait(reqSN, stat, ierr) + if (ierr /= MPI_SUCCESS) then + write (0, *) "Error in MPI_Wait = ", ierr + return + end if end if ierr = MPI_SUCCESS ! return with success flag @@ -632,12 +630,11 @@ integer(c_int) function Exchange(Nloc, t, sunvec_y, sunvec_ydot, & end function Exchange ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! Processor-local portion of the DAE residual function. ! ---------------------------------------------------------------- integer(c_int) function LocalFn(Nloc, t, sunvec_y, sunvec_ydot, sunvec_g, & - user_data) result(ierr) bind(C) + user_data) result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -648,16 +645,16 @@ integer(c_int) function LocalFn(Nloc, t, sunvec_y, sunvec_ydot, sunvec_g, & ! calling variables integer(c_int64_t), value :: Nloc - real(c_double), value :: t ! current time + real(c_double), value :: t ! current time type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_ydot ! rhs N_Vector type(N_Vector) :: sunvec_g ! evaluated N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer, dimension(nxl,nyl) :: y(:,:) - real(c_double), pointer, dimension(nxl,nyl) :: ydot(:,:) - real(c_double), pointer, dimension(nxl,nyl) :: res(:,:) + real(c_double), pointer, dimension(nxl, nyl) :: y(:, :) + real(c_double), pointer, dimension(nxl, nyl) :: ydot(:, :) + real(c_double), pointer, dimension(nxl, nyl) :: res(:, :) ! local data real(c_double) :: c1, c2, c3 @@ -666,9 +663,9 @@ integer(c_int) function LocalFn(Nloc, t, sunvec_y, sunvec_ydot, sunvec_g, & !======= Internals ============ ! Get data arrays from SUNDIALS vectors - y(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_y) - ydot(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_ydot) - res(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_g) + y(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_y) + ydot(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_ydot) + res(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_g) ! set constants c1 = kx/dx/dx @@ -679,45 +676,45 @@ integer(c_int) function LocalFn(Nloc, t, sunvec_y, sunvec_ydot, sunvec_g, & res = y ! iterate over subdomain boundaries (if not at overall domain boundary) - do i = 1,nxl - do j = 1,nyl - if (i == 1 .and. j == 1) then - if (HaveNbor(1,1) .and. HaveNbor(2,1)) then ! South-West corner - res(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j) - end if - else if (i == 1 .and. j == nyl) then - if (HaveNbor(1,1) .and. HaveNbor(2,2)) then ! North-West corner - res(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j) - end if - else if (i == nxl .and. j == 1) then - if (HaveNbor(1,2) .and. HaveNbor(2,1)) then ! South-East corner - res(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j) - end if - else if (i == nxl .and. j == nyl) then - if (HaveNbor(1,2) .and. HaveNbor(2,2)) then ! North-East corner - res(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j) - end if - else if (i == 1) then - if (HaveNbor(1,1)) then ! West face - res(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j) - end if - else if (i == nxl) then - if (HaveNbor(1,2)) then ! East face - res(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j) - end if - else if (j == 1) then - if (HaveNbor(2,1)) then ! South face - res(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j) - end if - else if (j == nyl) then - if (HaveNbor(2,2)) then ! North face - res(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j) - end if - else - res(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j) + do i = 1, nxl + do j = 1, nyl + if (i == 1 .and. j == 1) then + if (HaveNbor(1, 1) .and. HaveNbor(2, 1)) then ! South-West corner + res(i, j) = c1*(Wrecv(j) + y(i + 1, j)) + c2*(Srecv(i) + y(i, j + 1)) + c3*y(i, j) + end if + else if (i == 1 .and. j == nyl) then + if (HaveNbor(1, 1) .and. HaveNbor(2, 2)) then ! North-West corner + res(i, j) = c1*(Wrecv(j) + y(i + 1, j)) + c2*(y(i, j - 1) + Nrecv(i)) + c3*y(i, j) + end if + else if (i == nxl .and. j == 1) then + if (HaveNbor(1, 2) .and. HaveNbor(2, 1)) then ! South-East corner + res(i, j) = c1*(y(i - 1, j) + Erecv(j)) + c2*(Srecv(i) + y(i, j + 1)) + c3*y(i, j) + end if + else if (i == nxl .and. j == nyl) then + if (HaveNbor(1, 2) .and. HaveNbor(2, 2)) then ! North-East corner + res(i, j) = c1*(y(i - 1, j) + Erecv(j)) + c2*(y(i, j - 1) + Nrecv(i)) + c3*y(i, j) + end if + else if (i == 1) then + if (HaveNbor(1, 1)) then ! West face + res(i, j) = c1*(Wrecv(j) + y(i + 1, j)) + c2*(y(i, j - 1) + y(i, j + 1)) + c3*y(i, j) + end if + else if (i == nxl) then + if (HaveNbor(1, 2)) then ! East face + res(i, j) = c1*(y(i - 1, j) + Erecv(j)) + c2*(y(i, j - 1) + y(i, j + 1)) + c3*y(i, j) end if - res(i,j) = ydot(i,j) - res(i,j) - end do + else if (j == 1) then + if (HaveNbor(2, 1)) then ! South face + res(i, j) = c1*(y(i - 1, j) + y(i + 1, j)) + c2*(Srecv(i) + y(i, j + 1)) + c3*y(i, j) + end if + else if (j == nyl) then + if (HaveNbor(2, 2)) then ! North face + res(i, j) = c1*(y(i - 1, j) + y(i + 1, j)) + c2*(y(i, j - 1) + Nrecv(i)) + c3*y(i, j) + end if + else + res(i, j) = c1*(y(i - 1, j) + y(i + 1, j)) + c2*(y(i, j - 1) + y(i, j + 1)) + c3*y(i, j) + end if + res(i, j) = ydot(i, j) - res(i, j) + end do end do ierr = 0 ! Return with success @@ -728,7 +725,6 @@ end function LocalFn end module Heat2DKryBBD_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -763,9 +759,9 @@ program driver type(N_Vector), pointer :: sunvec_id ! derivative N_Vector type(N_Vector), pointer :: sunvec_res ! derivative N_Vector type(N_Vector), pointer :: sunvec_c ! constraint N_Vector - real(c_double), pointer, dimension(nxl,nyl) :: y(:,:) ! vector data + real(c_double), pointer, dimension(nxl, nyl) :: y(:, :) ! vector data type(SUNLinearSolver), pointer :: sun_LS ! linear solver - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix type(c_ptr) :: ida_mem ! IDA memory integer(c_int) :: retval integer :: ierr, case @@ -777,13 +773,13 @@ program driver ! initialize MPI call MPI_Init(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + write (0, *) "Error in MPI_Init = ", ierr + stop 1 end if call MPI_Comm_rank(MPI_COMM_WORLD, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Initialize Heat2DData module @@ -792,75 +788,75 @@ program driver ny = ny_ kx = kx_ ky = ky_ - dx = 1.d0/dble(nx-1) ! x mesh spacing - dy = 1.d0/dble(ny-1) ! x mesh spacing + dx = 1.d0/dble(nx - 1) ! x mesh spacing + dy = 1.d0/dble(ny - 1) ! x mesh spacing ! Set up parallel decomposition (computes local mesh sizes) call SetupDecomp(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in SetupDecomp = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in SetupDecomp = ", ierr + call MPI_Abort(comm, 1, ierr) end if ! Create SUNDIALS simulation context, now that comm has been configured retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then - print *, "Error: FSUNContext_Create returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNContext_Create returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Initial problem output outproc = (myid == 0) if (outproc) then - write(6,*) " " - write(6,*) "2D Heat PDE test problem:"; - write(6,'(A,i4)') " nprocs = " , nprocs - write(6,'(A,i4)') " nx = ", nx - write(6,'(A,i4)') " ny = ", ny - write(6,'(A,f5.2)') " kx = ", kx - write(6,'(A,f5.2)') " ky = ", ky - write(6,'(A,es9.2)') " rtol = ", rtol - write(6,'(A,es9.2)') " atol = ", atol - write(6,'(A,i4)') " nxl (proc 0) = ", nxl - write(6,'(A,i4)') " nyl (proc 0) = ", nyl - write(6,*) " " + write (6, *) " " + write (6, *) "2D Heat PDE test problem:"; + write (6, '(A,i4)') " nprocs = ", nprocs + write (6, '(A,i4)') " nx = ", nx + write (6, '(A,i4)') " ny = ", ny + write (6, '(A,f5.2)') " kx = ", kx + write (6, '(A,f5.2)') " ky = ", ky + write (6, '(A,es9.2)') " rtol = ", rtol + write (6, '(A,es9.2)') " atol = ", atol + write (6, '(A,i4)') " nxl (proc 0) = ", nxl + write (6, '(A,i4)') " nyl (proc 0) = ", nyl + write (6, *) " " end if ! Create the IDA timestepper module ida_mem = FIDACreate(sunctx) if (.not. c_associated(ida_mem)) then - print *, "Error: FIDACreate returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDACreate returned NULL" + call MPI_Abort(comm, 1, ierr) end if call InitProfile(sunvec_y, sunvec_f, sunvec_id, sunvec_res, sunvec_c, ierr) retval = FIDAInit(ida_mem, c_funloc(resfn), t0, sunvec_y, sunvec_f) if (retval /= 0) then - print *, "Error: FIDAInit returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDAInit returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Create linear solver maxl = 0 sun_LS => FSUNLinSol_SPGMR(sunvec_y, SUN_PREC_LEFT, maxl, sunctx) if (.not. associated(sun_LS)) then - print *, "Error: FSUNLinSol_PCG returned NULL" - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNLinSol_PCG returned NULL" + call MPI_Abort(comm, 1, ierr) end if ! Attach linear solver sunmat_A => null() retval = FIDASetLinearSolver(ida_mem, sun_LS, sunmat_A) if (retval /= 0) then - print *, "Error: FIDASetLinearSolver returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDASetLinearSolver returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FSUNLinSol_SPGMRSetMaxRestarts(sun_LS, 5) if (retval /= 0) then - print *, "Error: FSUNLinSol_SPGMRSetMaxRestarts returned",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FSUNLinSol_SPGMRSetMaxRestarts returned", retval + call MPI_Abort(comm, 1, ierr) end if ! Attach preconditioner @@ -869,159 +865,159 @@ program driver mu = 1 ml = 1 retval = FIDABBDPrecInit(ida_mem, N, mudq, mldq, mu, ml, 0.d0, & - c_funloc(LocalFn), c_funloc(Exchange)) + c_funloc(LocalFn), c_funloc(Exchange)) if (retval /= 0) then - print *, "Error: FIDASetPreconditioner returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDASetPreconditioner returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Specify tolerances retval = FIDASStolerances(ida_mem, rtol, atol) if (retval /= 0) then - print *, "Error: FIDASStolerances returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDASStolerances returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDASetSuppressAlg(ida_mem, SUNTRUE) if (retval /= 0) then - print *, "Error: FIDASetSuppressAlg returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDASetSuppressAlg returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDASetId(ida_mem, sunvec_id) if (retval /= 0) then - print *, "Error: FIDASetId returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDASetId returned ", retval + call MPI_Abort(comm, 1, ierr) end if retval = FIDASetConstraints(ida_mem, sunvec_c) if (retval /= 0) then - print *, "Error: FIDASetConstraints returned ",retval - call MPI_Abort(comm, 1, ierr) + print *, "Error: FIDASetConstraints returned ", retval + call MPI_Abort(comm, 1, ierr) end if ! Each processor outputs subdomain information - write(outname,'(16Hheat2d_subdomain,f4.3,4H.txt)') myid/1000.0 - open(100, file=outname) - write(100,'(6(i9,1x))') nx, ny, is, ie, js, je - close(100) + write (outname, '(16Hheat2d_subdomain,f4.3,4H.txt)') myid/1000.0 + open (100, file=outname) + write (100, '(6(i9,1x))') nx, ny, is, ie, js, je + close (100) ! Open output streams for results, access data array - write(outname,'(6Hheat2d,f4.3,4H.txt)') myid/1000.0 - open(101, file=outname) + write (outname, '(6Hheat2d,f4.3,4H.txt)') myid/1000.0 + open (101, file=outname) ! Output initial condition to disk - y(1:nxl,1:nyl) => FN_VGetArrayPointer(sunvec_y) - do j=1,nyl - do i=1,nxl - write(101,'(es25.16)',advance='no') y(i,j) - end do + y(1:nxl, 1:nyl) => FN_VGetArrayPointer(sunvec_y) + do j = 1, nyl + do i = 1, nxl + write (101, '(es25.16)', advance='no') y(i, j) + end do end do - write(101,*) " " - - do case = 1,2 - if (case == 2) then - mudq = 5 - mldq = 5 - call InitProfile(sunvec_y, sunvec_f, sunvec_id, sunvec_res, sunvec_c, ierr) - retval = FIDAReInit(ida_mem, t0, sunvec_y, sunvec_f) - if (retval /= 0) then - print *, "Error: FIDAReInit returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - retval = FIDABBDPrecReInit(ida_mem, mudq, mldq, 0.d0) - if (retval /= 0) then - print *, "Error: FIDABBDPrecReInit returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - if(outproc) then - write(6,*) " " - write(6,*) "Case ", case - write(6,*) " Difference quotient half-bandwidths = ", mudq - write(6,*) " Retained matrix half-bandwidths = ", mu - write(6,*) " " - write(6,*) "Output Summary" - write(6,*) " umax = max-norm of solution" - write(6,*) " nre = nre + nreLS (total number of RES evals.)" - end if - end if - if (case == 1) then - if(outproc) then - write(6,*) " " - write(6,*) "Case ", case - write(6,*) " Difference quotient half-bandwidths = ", mudq - write(6,*) " Retained matrix half-bandwidths = ", mu - write(6,*) " " - write(6,*) "Output Summary" - write(6,*) " umax = max-norm of solution" - write(6,*) " nre = nre + nreLS (total number of RES evals.)" - end if - end if - ! Main time-stepping loop: calls IDA to perform the integration, then - ! prints results. Stops when the final time has been reached - t = T0 - tout = T1 - if (outproc) then - write(6,*) " " - write(6,*) " t ||u||_max k nst nni nli nre nge h npe nps" - write(6,*) " ------------------------------------------------------------------------------------" - end if - do ioutput=1,Nt - - ! Integrate to output time - retval = FIDASolve(ida_mem, tout, t, sunvec_y, sunvec_f, IDA_NORMAL) - if (retval /= 0) then - print *, "Error: FIDASolve returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + write (101, *) " " + + do case = 1, 2 + if (case == 2) then + mudq = 5 + mldq = 5 + call InitProfile(sunvec_y, sunvec_f, sunvec_id, sunvec_res, sunvec_c, ierr) + retval = FIDAReInit(ida_mem, t0, sunvec_y, sunvec_f) + if (retval /= 0) then + print *, "Error: FIDAReInit returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + retval = FIDABBDPrecReInit(ida_mem, mudq, mldq, 0.d0) + if (retval /= 0) then + print *, "Error: FIDABBDPrecReInit returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + if (outproc) then + write (6, *) " " + write (6, *) "Case ", case + write (6, *) " Difference quotient half-bandwidths = ", mudq + write (6, *) " Retained matrix half-bandwidths = ", mu + write (6, *) " " + write (6, *) "Output Summary" + write (6, *) " umax = max-norm of solution" + write (6, *) " nre = nre + nreLS (total number of RES evals.)" + end if + end if + if (case == 1) then + if (outproc) then + write (6, *) " " + write (6, *) "Case ", case + write (6, *) " Difference quotient half-bandwidths = ", mudq + write (6, *) " Retained matrix half-bandwidths = ", mu + write (6, *) " " + write (6, *) "Output Summary" + write (6, *) " umax = max-norm of solution" + write (6, *) " nre = nre + nreLS (total number of RES evals.)" + end if + end if + ! Main time-stepping loop: calls IDA to perform the integration, then + ! prints results. Stops when the final time has been reached + t = T0 + tout = T1 + if (outproc) then + write (6, *) " " + write (6, *) " t ||u||_max k nst nni nli nre nge h npe nps" + write (6, *) " ------------------------------------------------------------------------------------" + end if + do ioutput = 1, Nt - ! print solution stats and update internal time - ymax = FN_VMaxNorm(sunvec_y) - call getStats(ida_mem, retval, ierr) - if (outproc) write(6,'(2x,f10.6,2x,es13.5,3x,i1,3x,i2,3x,i3,3x,i3,3x,i3,a,i3,3x,i4,3x,es9.2,3x,i2,3x,i3)') & - t, ymax, k, nst, nni, nli, nre, "+", nreLS, nge, h, npre, npsol - tout = 2.0d0 * tout - - ! output results to disk - do j=1,nyl - do i=1,nxl - write(101,'(es25.16)',advance='no') y(i,j) - end do + ! Integrate to output time + retval = FIDASolve(ida_mem, tout, t, sunvec_y, sunvec_f, IDA_NORMAL) + if (retval /= 0) then + print *, "Error: FIDASolve returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! print solution stats and update internal time + ymax = FN_VMaxNorm(sunvec_y) + call getStats(ida_mem, retval, ierr) + if (outproc) write (6, '(2x,f10.6,2x,es13.5,3x,i1,3x,i2,3x,i3,3x,i3,3x,i3,a,i3,3x,i4,3x,es9.2,3x,i2,3x,i3)') & + t, ymax, k, nst, nni, nli, nre, "+", nreLS, nge, h, npre, npsol + tout = 2.0d0*tout + + ! output results to disk + do j = 1, nyl + do i = 1, nxl + write (101, '(es25.16)', advance='no') y(i, j) end do - write(101,*) " " + end do + write (101, *) " " - end do - if (outproc) then - write(6,*) " ------------------------------------------------------------------------------------" - end if - close(101) + end do + if (outproc) then + write (6, *) " ------------------------------------------------------------------------------------" + end if + close (101) - retval = FIDAGetNumErrTestFails(ida_mem, netf) - if (retval /= 0) then - print *, "Error: FIDAGetNumErrTestFails returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FIDAGetNumErrTestFails(ida_mem, netf) + if (retval /= 0) then + print *, "Error: FIDAGetNumErrTestFails returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - retval = FIDAGetNumNonlinSolvConvFails(ida_mem, nncf) - if (retval /= 0) then - print *, "Error: FIDAInit returned ",retval - call MPI_Abort(comm, 1, ierr) - end if + retval = FIDAGetNumNonlinSolvConvFails(ida_mem, nncf) + if (retval /= 0) then + print *, "Error: FIDAInit returned ", retval + call MPI_Abort(comm, 1, ierr) + end if - retval = FIDAGetNumLinConvFails(ida_mem, nlcf) - if (retval /= 0) then - print *, "Error: FIDAInit returned ",retval - call MPI_Abort(comm, 1, ierr) - end if - - ! Print some final statistics - if (outproc) then - write(6,*) " " - write(6,*) "Final Solver Statistics:" - write(6,'(A,i6)') " Total number of error test failures = ", netf - write(6,'(A,i6)') " Total number of nonlinear conv. failures = ", nncf - write(6,'(A,i6)') " Total number of linear conv. failures = ", nlcf - end if + retval = FIDAGetNumLinConvFails(ida_mem, nlcf) + if (retval /= 0) then + print *, "Error: FIDAInit returned ", retval + call MPI_Abort(comm, 1, ierr) + end if + + ! Print some final statistics + if (outproc) then + write (6, *) " " + write (6, *) "Final Solver Statistics:" + write (6, '(A,i6)') " Total number of error test failures = ", netf + write (6, '(A,i6)') " Total number of nonlinear conv. failures = ", nncf + write (6, '(A,i6)') " Total number of linear conv. failures = ", nlcf + end if end do ! Clean up and return with successful completion diff --git a/examples/ida/F2003_serial/idaHeat2D_kry_f2003.f90 b/examples/ida/F2003_serial/idaHeat2D_kry_f2003.f90 index a8fd742d0e..80fd7fdc00 100644 --- a/examples/ida/F2003_serial/idaHeat2D_kry_f2003.f90 +++ b/examples/ida/F2003_serial/idaHeat2D_kry_f2003.f90 @@ -44,13 +44,13 @@ module dae_mod !======= Declarations ========= implicit none - integer(c_int), parameter :: nout = 11 - integer(c_int), parameter :: mgrid = 10 - integer(c_int64_t), parameter :: neq = mgrid*mgrid + integer(c_int), parameter :: nout = 11 + integer(c_int), parameter :: mgrid = 10 + integer(c_int64_t), parameter :: neq = mgrid*mgrid real(c_double) :: dx real(c_double) :: coeff - real(c_double) :: pp(mgrid,mgrid) + real(c_double) :: pp(mgrid, mgrid) contains @@ -63,7 +63,7 @@ module dae_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) & - result(ierr) bind(C,name='resHeat') + result(ierr) bind(C, name='resHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -76,12 +76,12 @@ integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_up ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: u(:,:) - real(c_double), pointer :: up(:,:) - real(c_double), pointer :: r(:,:) + real(c_double), pointer :: u(:, :) + real(c_double), pointer :: up(:, :) + real(c_double), pointer :: r(:, :) ! local variables integer(c_int64_t) :: i, j @@ -89,18 +89,18 @@ integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) !======= Internals ============ ! get data arrays from SUNDIALS vectors - u(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) + u(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up) - r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) + r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) ! Initialize r to u, to take care of boundary equations r = u ! Loop over interior points; set res = up - (central difference) - do j = 2,mgrid-1 - do i = 2,mgrid-1 - r(i,j) = up(i,j) - coeff*( u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1) - 4.d0*u(i,j)) - end do + do j = 2, mgrid - 1 + do i = 2, mgrid - 1 + r(i, j) = up(i, j) - coeff*(u(i - 1, j) + u(i + 1, j) + u(i, j - 1) + u(i, j + 1) - 4.d0*u(i, j)) + end do end do ! return success @@ -118,7 +118,7 @@ end function resHeat ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_data) & - result(ierr) bind(C,name='PSetupHeat') + result(ierr) bind(C, name='PSetupHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -133,7 +133,7 @@ integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_da type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_up ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector - type(c_ptr), value :: prec_data ! preconditioner data + type(c_ptr), value :: prec_data ! preconditioner data ! local variables real(c_double) :: pelinv @@ -147,7 +147,7 @@ integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_da pelinv = 1.d0/(cj + 4.d0*coeff) ! set the interior points to the correct value for preconditioning - pp(2:mgrid-1, 2:mgrid-1) = pelinv + pp(2:mgrid - 1, 2:mgrid - 1) = pelinv ! return success ierr = 0 @@ -164,12 +164,11 @@ end function PSetupHeat ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, & - sunvec_sol, cj, delta, prec_data) result(ierr) bind(C,name='PSolveHeat') + sunvec_sol, cj, delta, prec_data) result(ierr) bind(C, name='PSolveHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none @@ -182,11 +181,11 @@ integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, type(N_Vector) :: sunvec_r ! residual N_Vector type(N_Vector) :: sunvec_rhs ! rhs N_Vector type(N_Vector) :: sunvec_sol ! solution N_Vector - type(c_ptr), value :: prec_data ! preconditioner data + type(c_ptr), value :: prec_data ! preconditioner data ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: rhs(:,:) - real(c_double), pointer :: sol(:,:) + real(c_double), pointer :: rhs(:, :) + real(c_double), pointer :: sol(:, :) !======= Internals ============ @@ -195,7 +194,7 @@ integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, sol(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_sol) ! Apply preconditioner to rhs to create sol - sol = rhs * pp + sol = rhs*pp ! return success ierr = 0 @@ -206,7 +205,6 @@ end function PSolveHeat end module dae_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -226,48 +224,48 @@ program main integer(c_int) :: retval, iout integer(c_long) :: netf(1), ncfn(1), ncfl(1) - type(N_Vector), pointer :: sunvec_u ! sundials solution vector - type(N_Vector), pointer :: sunvec_up ! sundials derivative vector - type(N_Vector), pointer :: sunvec_c ! sundials constraints vector - type(N_Vector), pointer :: sunvec_r ! sundials residual vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(N_Vector), pointer :: sunvec_u ! sundials solution vector + type(N_Vector), pointer :: sunvec_up ! sundials derivative vector + type(N_Vector), pointer :: sunvec_c ! sundials constraints vector + type(N_Vector), pointer :: sunvec_r ! sundials residual vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: ida_mem ! IDA memory type(c_ptr) :: sunctx ! sundials simulation context ! solution, residual and constraints vectors, mgrid is set in the dae_mod module - real(c_double), dimension(mgrid,mgrid) :: uu, up, res, constraints + real(c_double), dimension(mgrid, mgrid) :: uu, up, res, constraints !======= Internals ============ retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) ! Assign parameters in dae_mod - dx = 1.d0/(mgrid-1) - coeff = 1.d0/(dx * dx) + dx = 1.d0/(mgrid - 1) + coeff = 1.d0/(dx*dx) ! create N_Vectors sunvec_u => FN_VMake_Serial(neq, uu, sunctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_up => FN_VMake_Serial(neq, up, sunctx) if (.not. associated(sunvec_up)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_r => FN_VMake_Serial(neq, res, sunctx) if (.not. associated(sunvec_r)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_c => FN_VMake_Serial(neq, constraints, sunctx) if (.not. associated(sunvec_c)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! Initialize solution vectors @@ -277,64 +275,64 @@ program main constraints = 1.d0 ! Assign various parameters - t0 = 0.d0 - t1 = 0.01d0 + t0 = 0.d0 + t1 = 0.01d0 rtol = 0.d0 atol = 1.d-3 ! Call FIDACreate and FIDAInit to initialize solution ida_mem = FIDACreate(sunctx) if (.not. c_associated(ida_mem)) then - print *, 'ERROR: ida_mem = NULL' - stop 1 + print *, 'ERROR: ida_mem = NULL' + stop 1 end if retval = FIDASetConstraints(ida_mem, sunvec_c) if (retval /= 0) then - print *, 'Error in FIDASetConstraints, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetConstraints, retval = ', retval, '; halting' + stop 1 end if retval = FIDAInit(ida_mem, c_funloc(resHeat), t0, sunvec_u, sunvec_up) if (retval /= 0) then - print *, 'Error in FIDAInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAInit, retval = ', retval, '; halting' + stop 1 end if retval = FIDASStolerances(ida_mem, rtol, atol) if (retval /= 0) then - print *, 'Error in FIDASStolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASStolerances, retval = ', retval, '; halting' + stop 1 end if ! Create the linear solver SUNLinSol_SPGMR with left preconditioning ! and the default Krylov dimension sunlinsol_LS => FSUNLinSol_SPGMR(sunvec_u, SUN_PREC_LEFT, 0, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! IDA recommends allowing up to 5 restarts (default is 0) retval = FSUNLinSol_SPGMRSetMaxRestarts(sunlinsol_LS, 5) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' + stop 1 end if ! Attach the linear solver (will NULL SUNMatrix object) sunmat_A => null() retval = FIDASetLinearSolver(ida_mem, sunlinsol_LS, sunmat_A) if (retval /= 0) then - print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the preconditioner solve and setup functions */ retval = FIDASetPreconditioner(ida_mem, c_funloc(PsetupHeat), c_funloc(PsolveHeat)) if (retval /= 0) then - print *, 'Error in FIDASetPreconditioner, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetPreconditioner, retval = ', retval, '; halting' + stop 1 end if ! Print output heading @@ -358,33 +356,33 @@ program main ! Loop over output times, call IDASolve, and print results tout = t1 - do iout = 1,NOUT - retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) - if (retval < 0) then - print *, 'Error in FIDASolve, retval = ', retval, '; halting' - stop 1 - end if - call PrintOutput(ida_mem, tret(1), uu) - tout = 2.d0*tout + do iout = 1, NOUT + retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) + if (retval < 0) then + print *, 'Error in FIDASolve, retval = ', retval, '; halting' + stop 1 + end if + call PrintOutput(ida_mem, tret(1), uu) + tout = 2.d0*tout end do ! Print remaining counters retval = FIDAGetNumErrTestFails(ida_mem, netf) if (retval /= 0) then - print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvConvFails(ida_mem, ncfn) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinConvFails(ida_mem, ncfl) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if print *, " " @@ -404,14 +402,14 @@ program main retval = FIDAReInit(ida_mem, t0, sunvec_u, sunvec_up) if (retval /= 0) then - print *, 'Error in FIDAReInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAReInit, retval = ', retval, '; halting' + stop 1 end if retval = FSUNLinSol_SPGMRSetGSType(sunlinsol_LS, SUN_CLASSICAL_GS) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval, '; halting' + stop 1 end if ! Print case number, output table heading, and initial line of table @@ -427,34 +425,34 @@ program main ! Loop over output times, call IDASolve, and print results tout = t1 - do iout = 1,NOUT - retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) - if (retval < 0) then - print *, 'Error in FIDASolve, retval = ', retval, '; halting' - stop 1 - end if - call PrintOutput(ida_mem, tret(1), uu) - tout = 2.d0*tout + do iout = 1, NOUT + retval = FIDASolve(ida_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) + if (retval < 0) then + print *, 'Error in FIDASolve, retval = ', retval, '; halting' + stop 1 + end if + call PrintOutput(ida_mem, tret(1), uu) + tout = 2.d0*tout end do ! Print remaining counters retval = FIDAGetNumErrTestFails(ida_mem, netf) if (retval /= 0) then - print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvConvFails(ida_mem, ncfn) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinConvFails(ida_mem, ncfl) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if print *, " " @@ -473,7 +471,6 @@ program main end program main - ! ---------------------------------------------------------------- ! SetInitialProfile: routine to initialize u and up vectors. ! ---------------------------------------------------------------- @@ -493,9 +490,9 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) type(N_Vector) :: sunvec_r ! residual N_Vector ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: uu(:,:) - real(c_double), pointer :: up(:,:) - real(c_double), pointer :: r(:,:) + real(c_double), pointer :: uu(:, :) + real(c_double), pointer :: up(:, :) + real(c_double), pointer :: r(:, :) ! local variables integer(c_int64_t) :: i, j @@ -507,38 +504,37 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) ! get data arrays from SUNDIALS vectors uu(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up) - r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) + r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) !======= Internals ============ ! Initialize uu on all grid points - do j = 1,mgrid - yfact = dx * (j-1) - do i = 1,mgrid - xfact = dx * (i-1) - uu(i,j) = 16.d0 * xfact * (1.d0 - xfact) * yfact * (1.d0 - yfact) - end do + do j = 1, mgrid + yfact = dx*(j - 1) + do i = 1, mgrid + xfact = dx*(i - 1) + uu(i, j) = 16.d0*xfact*(1.d0 - xfact)*yfact*(1.d0 - yfact) + end do end do ! Initialize up vector to 0 up = 0.d0 ! resHeat sets res to negative of ODE RHS values at interior points - retval = resHeat(0.d0, sunvec_u, sunvec_up, sunvec_r, C_NULL_PTR) + retval = resHeat(0.d0, sunvec_u, sunvec_up, sunvec_r, c_null_ptr) ! Copy -r into up to get correct interior initial up values up = -r ! Set up at boundary points to zero - up(1,:) = 0.d0 - up(mgrid,:) = 0.d0 - up(:,1) = 0.d0 - up(:,mgrid) = 0.d0 + up(1, :) = 0.d0 + up(mgrid, :) = 0.d0 + up(:, 1) = 0.d0 + up(:, mgrid) = 0.d0 return end subroutine SetInitialProfile - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -561,16 +557,15 @@ subroutine PrintHeader(rtol, atol) print *, " Discretized heat equation on 2D unit square." print *, " Zero boundary conditions, polynomial initial conditions." print '(2(a,i2),a,i3)', " Mesh dimensions: ", mgrid, " x ", mgrid, & - " Total system size: ", neq + " Total system size: ", neq print *, " " - print '(2(a,f5.3))', "Tolerance parameters: rtol = ", rtol," atol = ", atol + print '(2(a,f5.3))', "Tolerance parameters: rtol = ", rtol, " atol = ", atol print *, "Constraints set to force all solution components >= 0." print *, "Linear solver: SPGMR, preconditioner using diagonal elements." return end subroutine PrintHeader - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -586,7 +581,7 @@ subroutine PrintOutput(ida_mem, t, uu) ! calling variable type(c_ptr) :: ida_mem - real(c_double) :: t, uu(mgrid,mgrid) + real(c_double) :: t, uu(mgrid, mgrid) ! internal variables integer(c_int) :: retval, kused(1) @@ -599,66 +594,65 @@ subroutine PrintOutput(ida_mem, t, uu) retval = FIDAGetLastOrder(ida_mem, kused) if (retval /= 0) then - print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumSteps(ida_mem, nst) if (retval /= 0) then - print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvIters(ida_mem, nni) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumResEvals(ida_mem, nre) if (retval /= 0) then - print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetLastStep(ida_mem, hused) if (retval /= 0) then - print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumJtimesEvals(ida_mem, nje) if (retval /= 0) then - print *, 'Error in FIDAGetNumJtimesEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumJtimesEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinIters(ida_mem, nli) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinIters, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinResEvals(ida_mem, nreLS) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumPrecEvals(ida_mem, npe) if (retval /= 0) then - print *, 'Error in FIDAGetNumPrecEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumPrecEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumPrecSolves(ida_mem, nps) if (retval /= 0) then - print *, 'Error in FIDAGetNumPrecSolves, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumPrecSolves, retval = ', retval, '; halting' + stop 1 end if - print '(f5.2,1x,es13.5,1x,i1,2x,3(i3,2x),2(i4,2x),es9.2,2x,2(i3,1x))', & - t, umax, kused, nst, nni, nje, nre, nreLS, hused(1), npe, nps + t, umax, kused, nst, nni, nje, nre, nreLS, hused(1), npe, nps end subroutine PrintOutput diff --git a/examples/ida/F2003_serial/idaRoberts_dns_f2003.f90 b/examples/ida/F2003_serial/idaRoberts_dns_f2003.f90 index 63a7807eec..96b0122858 100644 --- a/examples/ida/F2003_serial/idaRoberts_dns_f2003.f90 +++ b/examples/ida/F2003_serial/idaRoberts_dns_f2003.f90 @@ -64,7 +64,7 @@ module dae_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function resrob(tres, sunvec_y, sunvec_yp, sunvec_r, user_data) & - result(ierr) bind(C,name='resrob') + result(ierr) bind(C, name='resrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -79,7 +79,7 @@ integer(c_int) function resrob(tres, sunvec_y, sunvec_yp, sunvec_r, user_data) & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_yp ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: yval(:) @@ -89,15 +89,15 @@ integer(c_int) function resrob(tres, sunvec_y, sunvec_yp, sunvec_r, user_data) & !======= Internals ============ ! get data arrays from SUNDIALS vectors - yval => FN_VGetArrayPointer(sunvec_y) + yval => FN_VGetArrayPointer(sunvec_y) ypval => FN_VGetArrayPointer(sunvec_yp) - rval => FN_VGetArrayPointer(sunvec_r) + rval => FN_VGetArrayPointer(sunvec_r) ! fill residual vector - rval(1) = -0.04d0*yval(1) + 1.0d4*yval(2)*yval(3) - rval(2) = -rval(1) - 3.0d7*yval(2)**2 - ypval(2) - rval(1) = rval(1) - ypval(1) - rval(3) = yval(1) + yval(2) + yval(3) - 1.d0 + rval(1) = -0.04d0*yval(1) + 1.0d4*yval(2)*yval(3) + rval(2) = -rval(1) - 3.0d7*yval(2)**2 - ypval(2) + rval(1) = rval(1) - ypval(1) + rval(3) = yval(1) + yval(2) + yval(3) - 1.d0 ! return success ierr = 0 @@ -114,7 +114,7 @@ end function resrob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function grob(t, sunvec_y, sunvec_yp, gout, user_data) & - result(ierr) bind(C,name='grob') + result(ierr) bind(C, name='grob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -129,7 +129,7 @@ integer(c_int) function grob(t, sunvec_y, sunvec_yp, gout, user_data) & type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_yp ! derivative N_Vector real(c_double) :: gout(2) ! root function values - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: yval(:) @@ -158,8 +158,8 @@ end function grob ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jacrob(t, cj, sunvec_y, sunvec_yp, sunvec_r, & - sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & - result(ierr) bind(C,name='jacrob') + sunmat_J, user_data, sunvec_t1, sunvec_t2, sunvec_t3) & + result(ierr) bind(C, name='jacrob') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -176,15 +176,14 @@ integer(c_int) function jacrob(t, cj, sunvec_y, sunvec_yp, sunvec_r, & type(N_Vector) :: sunvec_yp ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 type(N_Vector) :: sunvec_t3 ! pointers to data in SUNDIALS vector and matrix real(c_double), pointer :: yval(:) - real(c_double), pointer :: J(:,:) - + real(c_double), pointer :: J(:, :) !======= Internals ============ @@ -193,15 +192,15 @@ integer(c_int) function jacrob(t, cj, sunvec_y, sunvec_yp, sunvec_r, & j(1:3, 1:3) => FSUNDenseMatrix_Data(sunmat_J) ! fill Jacobian entries - J(1,1) = -0.04d0 - cj - J(2,1) = 0.04d0 - J(3,1) = 1.d0 - J(1,2) = 1.d4*yval(3) - J(2,2) = -1.d4*yval(3) - 6.0d7*yval(2) - cj - J(3,2) = 1.d0 - J(1,3) = 1.d4*yval(2) - J(2,3) = -1.d4*yval(2) - J(3,3) = 1.d0 + J(1, 1) = -0.04d0 - cj + J(2, 1) = 0.04d0 + J(3, 1) = 1.d0 + J(1, 2) = 1.d4*yval(3) + J(2, 2) = -1.d4*yval(3) - 6.0d7*yval(2) - cj + J(3, 2) = 1.d0 + J(1, 3) = 1.d4*yval(2) + J(2, 3) = -1.d4*yval(2) + J(3, 3) = 1.d0 ! return success ierr = 0 @@ -233,16 +232,16 @@ integer(c_int) function check_ans(y, t, rtol, atol) result(passfail) ewt = 1.d0/(rtol*dabs(ref) + 10.d0*atol) ! compute the solution error - ref = y-ref - err = dsqrt( dot_product(ewt*ref,ewt*ref)/3 ) + ref = y - ref + err = dsqrt(dot_product(ewt*ref, ewt*ref)/3) ! is the solution within the tolerances (pass=0 or fail=1)? passfail = 0 - if (err .ge. 1.d0) then - passfail = 1 - print *, " " - print *, "SUNDIALS_WARNING: check_ans error=", err - print *, " " + if (err >= 1.d0) then + passfail = 1 + print *, " " + print *, "SUNDIALS_WARNING: check_ans error=", err + print *, " " end if return @@ -252,7 +251,6 @@ end function check_ans end module dae_mod ! ------------------------------------------------------------------ - program main !======= Inclusions =========== @@ -272,11 +270,11 @@ program main real(c_double) :: rtol, t0, tout1, tout, tret(1) integer(c_int) :: iout, retval, retvalr, nrtfn, rootsfound(2) - type(N_Vector), pointer :: sunvec_y ! sundials solution vector - type(N_Vector), pointer :: sunvec_yp ! sundials derivative vector - type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix - type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_yp ! sundials derivative vector + type(N_Vector), pointer :: sunvec_av ! sundials tolerance vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(SUNNonLinearSolver), pointer :: sunnonlin_NLS ! sundials nonlinear solver type(c_ptr) :: ida_mem ! IDA memory type(c_ptr) :: sunctx ! SUNDIALS simulation context @@ -306,20 +304,20 @@ program main ! create serial vectors sunvec_y => FN_VMake_Serial(neq, yval, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_yp => FN_VMake_Serial(neq, ypval, sunctx) if (.not. associated(sunvec_yp)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_av => FN_VMake_Serial(neq, avtol, sunctx) if (.not. associated(sunvec_av)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! set integration limits @@ -331,57 +329,57 @@ program main ! Call FIDACreate and FIDAInit to initialize IDA memory ida_mem = FIDACreate(sunctx) if (.not. c_associated(ida_mem)) then - print *, 'ERROR: ida_mem = NULL' - stop 1 + print *, 'ERROR: ida_mem = NULL' + stop 1 end if retval = FIDAInit(ida_mem, c_funloc(resrob), t0, sunvec_y, sunvec_yp) if (retval /= 0) then - print *, 'Error in FIDAInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAInit, retval = ', retval, '; halting' + stop 1 end if ! Call FIDASVtolerances to set tolerances retval = FIDASVtolerances(ida_mem, rtol, sunvec_av) if (retval /= 0) then - print *, 'Error in FIDASVtolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASVtolerances, retval = ', retval, '; halting' + stop 1 end if ! Call FIDARootInit to specify the root function grob with 2 components nrtfn = 2 retval = FIDARootInit(ida_mem, nrtfn, c_funloc(grob)) if (retval /= 0) then - print *, 'Error in FIDARootInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDARootInit, retval = ', retval, '; halting' + stop 1 end if ! Create dense SUNMatrix for use in linear solves sunmat_A => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_A)) then - print *, 'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! Create dense SUNLinearSolver object sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! Attach the matrix and linear solver - retval = FIDASetLinearSolver(ida_mem, sunlinsol_LS, sunmat_A); + retval = FIDASetLinearSolver(ida_mem, sunlinsol_LS, sunmat_A); if (retval /= 0) then - print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the user-supplied Jacobian routine retval = FIDASetJacFn(ida_mem, c_funloc(jacrob)) if (retval /= 0) then - print *, 'Error in FIDASetJacFn, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetJacFn, retval = ', retval, '; halting' + stop 1 end if ! Create Newton SUNNonlinearSolver object. IDA uses a @@ -390,15 +388,15 @@ program main ! solely for demonstration purposes. sunnonlin_NLS => FSUNNonlinSol_Newton(sunvec_y, sunctx) if (.not. associated(sunnonlin_NLS)) then - print *, 'ERROR: sunnonlinsol = NULL' - stop 1 + print *, 'ERROR: sunnonlinsol = NULL' + stop 1 end if ! Attach the nonlinear solver retval = FIDASetNonlinearSolver(ida_mem, sunnonlin_NLS) if (retval /= 0) then - print *, 'Error in FIDASetNonlinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetNonlinearSolver, retval = ', retval, '; halting' + stop 1 end if ! In loop, call IDASolve, print results, and test for error. @@ -408,29 +406,29 @@ program main tout = tout1 do - retval = FIDASolve(ida_mem, tout, tret, sunvec_y, sunvec_yp, IDA_NORMAL) - if (retval < 0) then - print *, 'Error in FIDASolve, retval = ', retval, '; halting' - stop 1 - endif + retval = FIDASolve(ida_mem, tout, tret, sunvec_y, sunvec_yp, IDA_NORMAL) + if (retval < 0) then + print *, 'Error in FIDASolve, retval = ', retval, '; halting' + stop 1 + end if - call PrintOutput(ida_mem, tret(1), yval) + call PrintOutput(ida_mem, tret(1), yval) - if (retval .eq. IDA_ROOT_RETURN) then - retvalr = FIDAGetRootInfo(ida_mem, rootsfound) - if (retvalr < 0) then - print *, 'Error in FIDAGetRootInfo, retval = ', retval, '; halting' - stop 1 - endif - print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) - end if + if (retval == IDA_ROOT_RETURN) then + retvalr = FIDAGetRootInfo(ida_mem, rootsfound) + if (retvalr < 0) then + print *, 'Error in FIDAGetRootInfo, retval = ', retval, '; halting' + stop 1 + end if + print '(a,2(i2,2x))', " rootsfound[] = ", rootsfound(1), rootsfound(2) + end if - if (retval .eq. IDA_SUCCESS) then - iout = iout+1 - tout = tout*10.d0 - end if + if (retval == IDA_SUCCESS) then + iout = iout + 1 + tout = tout*10.d0 + end if - if (iout .eq. NOUT) exit + if (iout == NOUT) exit end do @@ -450,7 +448,6 @@ program main end program main - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -475,8 +472,8 @@ subroutine PrintHeader(rtol, avtol, y) print *, " Three equation chemical kinetics problem." print *, " " print *, "Linear solver: DENSE, with user-supplied Jacobian." - print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ",rtol," atol = ", avtol - print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (",y,")" + print '(a,f6.4,a,3(es7.0,1x))', "Tolerance parameters: rtol = ", rtol, " atol = ", avtol + print '(a,3(f5.2,1x),a)', "Initial conditions y0 = (", y, ")" print *, "Constraints and id not used." print *, " " print *, "-----------------------------------------------------------------------" @@ -486,7 +483,6 @@ subroutine PrintHeader(rtol, avtol, y) return end subroutine PrintHeader - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -513,28 +509,27 @@ subroutine PrintOutput(ida_mem, t, y) retval = FIDAGetLastOrder(ida_mem, kused) if (retval /= 0) then - print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumSteps(ida_mem, nst) if (retval /= 0) then - print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetLastStep(ida_mem, hused) if (retval /= 0) then - print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' + stop 1 end if print '(es12.4,1x,3(es12.4,1x),a,i3,2x,i1,1x,es12.4)', & - t, y(1), y(2), y(3), "| ", nst, kused(1), hused(1) + t, y(1), y(2), y(3), "| ", nst, kused(1), hused(1) end subroutine PrintOutput - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -557,56 +552,56 @@ subroutine PrintFinalStats(ida_mem) retval = FIDAGetNumSteps(ida_mem, nst) if (retval /= 0) then - print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumResEvals(ida_mem, nre) if (retval /= 0) then - print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumJacEvals(ida_mem, nje) if (retval /= 0) then - print *, 'Error in FIDAGetNumJacEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumJacEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvIters(ida_mem, nni) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumErrTestFails(ida_mem, netf) if (retval /= 0) then - print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvConvFails(ida_mem, ncfn) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinResEvals(ida_mem, nreLS) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumGEvals(ida_mem, nge) if (retval /= 0) then - print *, 'Error in FIDAGetNumGEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumGEvals, retval = ', retval, '; halting' + stop 1 end if print *, " " print *, "Final Run Statistics: " print *, "Number of steps = ", nst - print *, "Number of residual evaluations = ", nre+nreLS + print *, "Number of residual evaluations = ", nre + nreLS print *, "Number of Jacobian evaluations = ", nje print *, "Number of nonlinear iterations = ", nni print *, "Number of error test failures = ", netf diff --git a/examples/idas/F2003_serial/idasAkzoNob_ASAi_dns_f2003.f90 b/examples/idas/F2003_serial/idasAkzoNob_ASAi_dns_f2003.f90 index d41404ff8f..7f2d4b80d4 100644 --- a/examples/idas/F2003_serial/idasAkzoNob_ASAi_dns_f2003.f90 +++ b/examples/idas/F2003_serial/idasAkzoNob_ASAi_dns_f2003.f90 @@ -33,7 +33,6 @@ module dae_mod use fsundials_core_mod implicit none - ! Since SUNDIALS can be compiled with 32-bit or 64-bit sunindextype ! we set the integer kind used for indices in this example based ! on the the index size SUNDIALS was compiled with so that it works @@ -47,23 +46,23 @@ module dae_mod ! problem parameters integer(kind=myindextype), parameter :: NEQ = 6 integer(c_long), parameter :: STEPS = 150 - real(c_double), parameter :: T0 = 0.0d0 - real(c_double), parameter :: TF = 180.d0 - real(c_double), parameter :: RTOL = 1e-08 - real(c_double), parameter :: ATOL = 1e-10 - real(c_double), parameter :: RTOLB = 1e-06 - real(c_double), parameter :: ATOLB = 1e-08 - real(c_double), parameter :: RTOLQ = 1e-10 - real(c_double), parameter :: ATOLQ = 1e-12 + real(c_double), parameter :: T0 = 0.0d0 + real(c_double), parameter :: TF = 180.d0 + real(c_double), parameter :: RTOL = 1e-08 + real(c_double), parameter :: ATOL = 1e-10 + real(c_double), parameter :: RTOLB = 1e-06 + real(c_double), parameter :: ATOLB = 1e-08 + real(c_double), parameter :: RTOLQ = 1e-10 + real(c_double), parameter :: ATOLQ = 1e-12 ! problem constants - real(c_double) :: ZERO = 0.0d0 + real(c_double) :: ZERO = 0.0d0 real(c_double) :: QUARTER = 0.25d0 - real(c_double) :: HALF = 0.5d0 - real(c_double) :: ONE = 1.0d0 - real(c_double) :: TWO = 2.0d0 - real(c_double) :: FOUR = 4.0d0 - real(c_double) :: EIGHT = 8.0d0 + real(c_double) :: HALF = 0.5d0 + real(c_double) :: ONE = 1.0d0 + real(c_double) :: TWO = 2.0d0 + real(c_double) :: FOUR = 4.0d0 + real(c_double) :: EIGHT = 8.0d0 ! problem data real(c_double) :: k1, k2, k3, k4 @@ -72,7 +71,7 @@ module dae_mod contains integer(c_int) function res(t, nv_yy, nv_yd, nv_resval, userdata) & - result(retval) bind(C,name='res') + result(retval) bind(C, name='res') use, intrinsic :: iso_c_binding implicit none @@ -88,8 +87,8 @@ integer(c_int) function res(t, nv_yy, nv_yd, nv_resval, userdata) & real(c_double) :: r1, r2, r3, r4, r5, Fin real(c_double), pointer :: yy(:), yd(:), resval(:) - yy => FN_VGetArrayPointer(nv_yy) - yd => FN_VGetArrayPointer(nv_yd) + yy => FN_VGetArrayPointer(nv_yy) + yd => FN_VGetArrayPointer(nv_yd) resval => FN_VGetArrayPointer(nv_resval) y1 = yy(1) @@ -105,12 +104,12 @@ integer(c_int) function res(t, nv_yy, nv_yd, nv_resval, userdata) & yd4 = yd(4) yd5 = yd(5) - r1 = k1 * (y1**4) * sqrt(y2) - r2 = k2 * y3 * y4 - r3 = k2/K * y1 * y5 - r4 = k3 * y1 * y4 * y4 - r5 = k4 * y6 * y6 * sqrt(y2) - Fin = klA * ( pCO2/H - y2 ) + r1 = k1*(y1**4)*sqrt(y2) + r2 = k2*y3*y4 + r3 = k2/K*y1*y5 + r4 = k3*y1*y4*y4 + r5 = k4*y6*y6*sqrt(y2) + Fin = klA*(pCO2/H - y2) resval(1) = yd1 + TWO*r1 - r2 + r3 + r4 resval(2) = yd2 + HALF*r1 + r4 + HALF*r5 - Fin @@ -124,7 +123,7 @@ integer(c_int) function res(t, nv_yy, nv_yd, nv_resval, userdata) & end function res integer(c_int) function rhsQ(t, nv_yy, nv_yp, nv_qdot, userdata) & - result(retval) bind(C,name='rhsQ') + result(retval) bind(C, name='rhsQ') use, intrinsic :: iso_c_binding implicit none @@ -138,7 +137,7 @@ integer(c_int) function rhsQ(t, nv_yy, nv_yp, nv_qdot, userdata) & real(c_double), pointer :: qdot(:), yy(:) qdot => FN_VGetArrayPointer(nv_qdot) - yy => FN_VGetArrayPointer(nv_yy) + yy => FN_VGetArrayPointer(nv_yy) qdot(1) = yy(1) retval = 0 @@ -146,7 +145,7 @@ integer(c_int) function rhsQ(t, nv_yy, nv_yp, nv_qdot, userdata) & end function rhsQ integer(c_int) function resB(tt, nv_yy, nv_yp, nv_yyB, nv_ypB, nv_rrB, userdata) & - result(retval) bind(C,name='resB') + result(retval) bind(C, name='resB') use, intrinsic :: iso_c_binding implicit none @@ -162,7 +161,7 @@ integer(c_int) function resB(tt, nv_yy, nv_yp, nv_yyB, nv_ypB, nv_rrB, userdata) real(c_double) :: y2tohalf, y1to3, k2overK, tmp1, tmp2 real(c_double), pointer :: yy(:), yyB(:), ypB(:), rrb(:) - yy => FN_VGetArrayPointer(nv_yy) + yy => FN_VGetArrayPointer(nv_yy) yyB => FN_VGetArrayPointer(nv_yyB) ypB => FN_VGetArrayPointer(nv_ypB) rrB => FN_VGetArrayPointer(nv_rrB) @@ -191,27 +190,27 @@ integer(c_int) function resB(tt, nv_yy, nv_yp, nv_yyB, nv_ypB, nv_rrB, userdata) y1to3 = y1*y1*y1 k2overK = k2/K - tmp1 = k1* y1to3 * y2tohalf + tmp1 = k1*y1to3*y2tohalf tmp2 = k3*y4*y4 - rrB(1) = 1 + ypB1 - (EIGHT*tmp1 + k2overK*y5 + tmp2)*yB1 & - - (TWO*tmp1+tmp2)*yB2 + (FOUR*tmp1+k2overK*y5)*yB3 & - + k2overK*y5*(yB4-yB5) - TWO*tmp2*yB4 + Ks*y4*yB6 + rrB(1) = 1 + ypB1 - (EIGHT*tmp1 + k2overK*y5 + tmp2)*yB1 & + - (TWO*tmp1 + tmp2)*yB2 + (FOUR*tmp1 + k2overK*y5)*yB3 & + + k2overK*y5*(yB4 - yB5) - TWO*tmp2*yB4 + Ks*y4*yB6 - tmp1 = k1 * y1*y1to3 * (y2tohalf/y2) - tmp2 = k4 * y6*y6 * (y2tohalf/y2) + tmp1 = k1*y1*y1to3*(y2tohalf/y2) + tmp2 = k4*y6*y6*(y2tohalf/y2) rrB(2) = ypB2 - tmp1*yB1 - (QUARTER*tmp1 + QUARTER*tmp2 + klA)*yB2 & - + HALF*tmp1*yB3 + HALF*tmp2*yB5 + + HALF*tmp1*yB3 + HALF*tmp2*yB5 - rrB(3) = ypB3 + k2*y4*(yB1-yB3-yB4+yB5) + rrB(3) = ypB3 + k2*y4*(yB1 - yB3 - yB4 + yB5) tmp1 = k3*y1*y4 tmp2 = k2*y3 - rrB(4) = ypB4 + (tmp2-TWO*tmp1)*yB1 - TWO*tmp1*yB2 - tmp2*yB3 & - - (tmp2+FOUR*tmp1)*yB4 + tmp2*yB5 + Ks*y1*yB6 + rrB(4) = ypB4 + (tmp2 - TWO*tmp1)*yB1 - TWO*tmp1*yB2 - tmp2*yB3 & + - (tmp2 + FOUR*tmp1)*yB4 + tmp2*yB5 + Ks*y1*yB6 - rrB(5) = ypB5 - k2overK*y1*(yB1-yB3-yB4+yB5) + rrB(5) = ypB5 - k2overK*y1*(yB1 - yB3 - yB4 + yB5) - rrB(6) = k4*y6*y2tohalf*(2*yB5-yB2) - yB6 + rrB(6) = k4*y6*y2tohalf*(2*yB5 - yB2) - yB6 retval = 0 return @@ -228,20 +227,19 @@ subroutine PrintOutput(nv_yB, nv_ypB) yB => FN_VGetArrayPointer(nv_yB) - write(*,'(1x,A,es12.4)') "dG/dy0: ", yB(1) - write(*,'(1x,A,es12.4)') " ", yB(2) - write(*,'(1x,A,es12.4)') " ", yB(3) - write(*,'(1x,A,es12.4)') " ", yB(4) - write(*,'(1x,A,es12.4)') " ", yB(5) - write(*,'(1x,A,es12.4)') " ", yB(6) - write(*,*) "--------------------------------------------------------" - write(*,*) "" + write (*, '(1x,A,es12.4)') "dG/dy0: ", yB(1) + write (*, '(1x,A,es12.4)') " ", yB(2) + write (*, '(1x,A,es12.4)') " ", yB(3) + write (*, '(1x,A,es12.4)') " ", yB(4) + write (*, '(1x,A,es12.4)') " ", yB(5) + write (*, '(1x,A,es12.4)') " ", yB(6) + write (*, *) "--------------------------------------------------------" + write (*, *) "" end subroutine end module dae_mod - ! Main program program main use, intrinsic :: iso_c_binding @@ -261,11 +259,11 @@ program main real(c_double) :: time(1) integer(c_long) :: nst(1), nstB(1) integer(c_int) :: indexB(1) - real(c_double), pointer :: yy(:), q(:) - type(N_Vector), pointer :: nv_yy, nv_yp, nv_rr, nv_q - real(c_double), pointer :: ypB(:) - type(N_Vector), pointer :: nv_yB, nv_ypB - type(SUNMatrix), pointer :: A, AB + real(c_double), pointer :: yy(:), q(:) + type(N_Vector), pointer :: nv_yy, nv_yp, nv_rr, nv_q + real(c_double), pointer :: ypB(:) + type(N_Vector), pointer :: nv_yB, nv_ypB + type(SUNMatrix), pointer :: A, AB type(SUNLinearSolver), pointer :: LS, LSB ! Consistent IC for y, y'. @@ -275,23 +273,23 @@ program main real(c_double) :: y04 = 0.007d0 real(c_double) :: y05 = 0.0d0 - write(*,*) "" - write(*,*) "Adjoint Sensitivity Example for Akzo-Nobel Chemical Kinetics" - write(*,*) "-------------------------------------------------------------" - write(*,*) "Sensitivity of G = int_t0^tf (y1) dt with respect to IC." - write(*,*) "-------------------------------------------------------------" - write(*,*) "" + write (*, *) "" + write (*, *) "Adjoint Sensitivity Example for Akzo-Nobel Chemical Kinetics" + write (*, *) "-------------------------------------------------------------" + write (*, *) "Sensitivity of G = int_t0^tf (y1) dt with respect to IC." + write (*, *) "-------------------------------------------------------------" + write (*, *) "" ! Fill problem data with the appropriate values for coefficients. - k1 = 18.7d0 - k2 = 0.58d0 - k3 = 0.09d0 - k4 = 0.42d0 - K = 34.4d0 - klA = 3.3d0 - Ks = 115.83d0 + k1 = 18.7d0 + k2 = 0.58d0 + k3 = 0.09d0 + k4 = 0.42d0 + K = 34.4d0 + klA = 3.3d0 + Ks = 115.83d0 pCO2 = 0.9d0 - H = 737.0d0 + H = 737.0d0 ! Create the SUNDIALS simulation context retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) @@ -302,18 +300,18 @@ program main nv_yp => FN_VNew_Serial(NEQ, sunctx) ! Set IC - yy => FN_VGetArrayPointer(nv_yy) + yy => FN_VGetArrayPointer(nv_yy) yy(1) = y01 yy(2) = y02 yy(3) = y03 yy(4) = y04 yy(5) = y05 - yy(6) = Ks * y01 * y04 + yy(6) = Ks*y01*y04 ! Get y' = - res(t0, y, 0) call FN_VConst(ZERO, nv_yp) - nv_rr => FN_VNew_Serial(NEQ, sunctx) + nv_rr => FN_VNew_Serial(NEQ, sunctx) retval = res(T0, nv_yy, nv_yp, nv_rr, c_null_ptr) call FN_VScale(-ONE, nv_rr, nv_yp) call FN_VDestroy(nv_rr) @@ -321,21 +319,21 @@ program main ! Create and initialize q0 for quadratures. nv_q => FN_VNew_Serial(1_myindextype, sunctx) if (.not. associated(nv_q)) then - write(*,*) 'ERROR: FN_VNew_Serial returned NULL' + write (*, *) 'ERROR: FN_VNew_Serial returned NULL' stop 1 end if - q => FN_VGetArrayPointer(nv_q) + q => FN_VGetArrayPointer(nv_q) if (.not. associated(q)) then - write(*,*) 'ERROR: FN_VGetArrayPointer returned NULL' + write (*, *) 'ERROR: FN_VGetArrayPointer returned NULL' stop 1 end if q(1) = ZERO ! Call FIDACreate and FIDAInit to initialize FIDA memory - mem = FIDACreate(sunctx) + mem = FIDACreate(sunctx) if (.not. c_associated(mem)) then - write(*,*) 'ERROR: FIDACreate returned NULL' + write (*, *) 'ERROR: FIDACreate returned NULL' stop 1 end if @@ -349,14 +347,14 @@ program main ! Create dense SUNMatrix for use in linear solves A => FSUNDenseMatrix(NEQ, NEQ, sunctx) if (.not. associated(A)) then - write(*,*) 'ERROR: FSUNDenseMatrix returned NULL' + write (*, *) 'ERROR: FSUNDenseMatrix returned NULL' stop 1 end if ! Create dense SUNLinearSolver object LS => FSUNLinSol_Dense(nv_yy, A, sunctx) if (.not. associated(LS)) then - write(*,*) 'ERROR: FSUNLinSol_Dense returned NULL' + write (*, *) 'ERROR: FSUNLinSol_Dense returned NULL' stop 1 end if @@ -380,34 +378,34 @@ program main call check_retval(retval, "FIDAAdjInit") ! FORWARD run. - write(*,'(1x,A)',advance='no') "Forward integration ... " + write (*, '(1x,A)', advance='no') "Forward integration ... " retval = FIDASolveF(mem, TF, time, nv_yy, nv_yp, IDA_NORMAL, ncheck) call check_retval(retval, "FIDASolveF") retval = FIDAGetNumSteps(mem, nst) - write(*,'(A,i6,A)') "done ( nst = ", nst, " )" + write (*, '(A,i6,A)') "done ( nst = ", nst, " )" retval = FIDAGetQuad(mem, time, nv_q) - write(*,'(1x,A,F24.16)') "G: ", q(1) - write(*,*) "--------------------------------------------------------" - write(*,*) "" + write (*, '(1x,A,F24.16)') "G: ", q(1) + write (*, *) "--------------------------------------------------------" + write (*, *) "" ! BACKWARD run ! Initialize yB nv_yB => FN_VNew_Serial(NEQ, sunctx) if (.not. associated(nv_yB)) then - write(*,*) 'ERROR: FN_VNew_Serial returned NULL' + write (*, *) 'ERROR: FN_VNew_Serial returned NULL' stop 1 end if call FN_VConst(ZERO, nv_yB) nv_ypB => FN_VNew_Serial(NEQ, sunctx) if (.not. associated(nv_ypB)) then - write(*,*) 'ERROR: FN_VNew_Serial returned NULL' + write (*, *) 'ERROR: FN_VNew_Serial returned NULL' stop 1 end if call FN_VConst(ZERO, nv_ypB) - ypB => FN_VGetArrayPointer(nv_ypB) + ypB => FN_VGetArrayPointer(nv_ypB) ypB(1) = -ONE retval = FIDACreateB(mem, indexB) @@ -425,14 +423,14 @@ program main ! Create dense SUNMatrix for use in linear solves AB => FSUNDenseMatrix(NEQ, NEQ, sunctx) if (.not. associated(AB)) then - write(*,*) 'ERROR: FSUNDenseMatrix returned NULL' + write (*, *) 'ERROR: FSUNDenseMatrix returned NULL' stop 1 end if ! Create dense SUNLinearSolver object LSB => FSUNLinSol_Dense(nv_yB, AB, sunctx) if (.not. associated(LSB)) then - write(*,*) 'ERROR: FSUNLinSol_Dense returned NULL' + write (*, *) 'ERROR: FSUNLinSol_Dense returned NULL' stop 1 end if @@ -441,12 +439,12 @@ program main call check_retval(retval, "FIDASetLinearSolverB") ! Do the backward integration - write(*,'(1x,A)',advance='no') "Backward integration ... " + write (*, '(1x,A)', advance='no') "Backward integration ... " retval = FIDASolveB(mem, T0, IDA_NORMAL) call check_retval(retval, "FIDASolveB") - memB = FIDAGetAdjIDABmem(mem, indexB(1)) + memB = FIDAGetAdjIDABmem(mem, indexB(1)) retval = FIDAGetNumSteps(memB, nstB) - write(*,'(A,i6,A)') "done ( nst = ", nstB, " )" + write (*, '(A,i6,A)') "done ( nst = ", nstB, " )" retval = FIDAGetB(mem, indexB(1), time, nv_yB, nv_ypB) ! Print the solution @@ -474,7 +472,7 @@ subroutine check_retval(retval, name) integer(c_int) :: retval if (retval < 0) then - write(*,'(A,A,A,I4)') 'ERROR: ', name,' returned ', retval + write (*, '(A,A,A,I4)') 'ERROR: ', name, ' returned ', retval stop 1 end if end subroutine diff --git a/examples/idas/F2003_serial/idasHeat2D_kry_f2003.f90 b/examples/idas/F2003_serial/idasHeat2D_kry_f2003.f90 index 9ecad4f265..4a5f9ea763 100644 --- a/examples/idas/F2003_serial/idasHeat2D_kry_f2003.f90 +++ b/examples/idas/F2003_serial/idasHeat2D_kry_f2003.f90 @@ -44,13 +44,13 @@ module dae_mod !======= Declarations ========= implicit none - integer(c_int), parameter :: nout = 11 - integer(c_int), parameter :: mgrid = 10 - integer(c_int64_t), parameter :: neq = mgrid*mgrid + integer(c_int), parameter :: nout = 11 + integer(c_int), parameter :: mgrid = 10 + integer(c_int64_t), parameter :: neq = mgrid*mgrid real(c_double) :: dx real(c_double) :: coeff - real(c_double) :: pp(mgrid,mgrid) + real(c_double) :: pp(mgrid, mgrid) contains @@ -63,7 +63,7 @@ module dae_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) & - result(ierr) bind(C,name='resHeat') + result(ierr) bind(C, name='resHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -76,12 +76,12 @@ integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_up ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: u(:,:) - real(c_double), pointer :: up(:,:) - real(c_double), pointer :: r(:,:) + real(c_double), pointer :: u(:, :) + real(c_double), pointer :: up(:, :) + real(c_double), pointer :: r(:, :) ! local variables integer(c_int64_t) :: i, j @@ -89,18 +89,18 @@ integer(c_int) function resHeat(tres, sunvec_u, sunvec_up, sunvec_r, user_data) !======= Internals ============ ! get data arrays from SUNDIALS vectors - u(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) + u(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up) - r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) + r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) ! Initialize r to u, to take care of boundary equations r = u ! Loop over interior points; set res = up - (central difference) - do j = 2,mgrid-1 - do i = 2,mgrid-1 - r(i,j) = up(i,j) - coeff*( u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1) - 4.d0*u(i,j)) - end do + do j = 2, mgrid - 1 + do i = 2, mgrid - 1 + r(i, j) = up(i, j) - coeff*(u(i - 1, j) + u(i + 1, j) + u(i, j - 1) + u(i, j + 1) - 4.d0*u(i, j)) + end do end do ! return success @@ -118,7 +118,7 @@ end function resHeat ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_data) & - result(ierr) bind(C,name='PSetupHeat') + result(ierr) bind(C, name='PSetupHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -134,7 +134,7 @@ integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_da type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_up ! derivative N_Vector type(N_Vector) :: sunvec_r ! residual N_Vector - type(c_ptr), value :: prec_data ! preconditioner data + type(c_ptr), value :: prec_data ! preconditioner data ! local variables real(c_double) :: pelinv @@ -148,7 +148,7 @@ integer(c_int) function PSetupHeat(t, sunvec_u, sunvec_up, sunvec_r, cj, prec_da pelinv = 1.d0/(cj + 4.d0*coeff) ! set the interior points to the correct value for preconditioning - pp(2:mgrid-1, 2:mgrid-1) = pelinv + pp(2:mgrid - 1, 2:mgrid - 1) = pelinv ! return success ierr = 0 @@ -165,12 +165,11 @@ end function PSetupHeat ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, & - sunvec_sol, cj, delta, prec_data) result(ierr) bind(C,name='PSolveHeat') + sunvec_sol, cj, delta, prec_data) result(ierr) bind(C, name='PSolveHeat') !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none @@ -183,11 +182,11 @@ integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, type(N_Vector) :: sunvec_r ! residual N_Vector type(N_Vector) :: sunvec_rhs ! rhs N_Vector type(N_Vector) :: sunvec_sol ! solution N_Vector - type(c_ptr), value :: prec_data ! preconditioner data + type(c_ptr), value :: prec_data ! preconditioner data ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: rhs(:,:) - real(c_double), pointer :: sol(:,:) + real(c_double), pointer :: rhs(:, :) + real(c_double), pointer :: sol(:, :) !======= Internals ============ @@ -196,7 +195,7 @@ integer(c_int) function PSolveHeat(t, sunvec_u, sunvec_up, sunvec_r, sunvec_rhs, sol(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_sol) ! Apply preconditioner to rhs to create sol - sol = rhs * pp + sol = rhs*pp ! return success ierr = 0 @@ -207,7 +206,6 @@ end function PSolveHeat end module dae_mod ! ------------------------------------------------------------------ - program main use, intrinsic :: iso_c_binding use fsundials_core_mod @@ -223,22 +221,22 @@ program main integer(c_long) :: netf(1), ncfn(1), ncfl(1) type(c_ptr) :: sunctx - type(N_Vector), pointer :: sunvec_u ! sundials solution vector - type(N_Vector), pointer :: sunvec_up ! sundials derivative vector - type(N_Vector), pointer :: sunvec_c ! sundials constraints vector - type(N_Vector), pointer :: sunvec_r ! sundials residual vector - type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) + type(N_Vector), pointer :: sunvec_u ! sundials solution vector + type(N_Vector), pointer :: sunvec_up ! sundials derivative vector + type(N_Vector), pointer :: sunvec_c ! sundials constraints vector + type(N_Vector), pointer :: sunvec_r ! sundials residual vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix (empty) type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: idas_mem ! IDA memory ! Solution, residual and constraints vectors, mgrid is set in the dae_mod module - real(c_double), dimension(mgrid,mgrid) :: uu, up, res, constraints + real(c_double), dimension(mgrid, mgrid) :: uu, up, res, constraints !======= Internals ============ ! Assign parameters in dae_mod - dx = 1.d0/(mgrid-1) - coeff = 1.d0/(dx * dx) + dx = 1.d0/(mgrid - 1) + coeff = 1.d0/(dx*dx) ! Create the SUNDIALS simulation context retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) @@ -250,26 +248,26 @@ program main ! Create N_Vectors sunvec_u => FN_VMake_Serial(neq, uu, sunctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_up => FN_VMake_Serial(neq, up, sunctx) if (.not. associated(sunvec_up)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_r => FN_VMake_Serial(neq, res, sunctx) if (.not. associated(sunvec_r)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_c => FN_VMake_Serial(neq, constraints, sunctx) if (.not. associated(sunvec_c)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! Initialize solution vectors @@ -279,64 +277,64 @@ program main constraints = 1.d0 ! Assign various parameters - t0 = 0.d0 - t1 = 0.01d0 + t0 = 0.d0 + t1 = 0.01d0 rtol = 0.d0 atol = 1.d-3 ! Call FIDACreate and FIDAInit to initialize solution idas_mem = FIDACreate(sunctx) if (.not. c_associated(idas_mem)) then - print *, 'ERROR: idas_mem = NULL' - stop 1 + print *, 'ERROR: idas_mem = NULL' + stop 1 end if retval = FIDASetConstraints(idas_mem, sunvec_c) if (retval /= 0) then - print *, 'Error in FIDASetConstraints, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetConstraints, retval = ', retval, '; halting' + stop 1 end if retval = FIDAInit(idas_mem, c_funloc(resHeat), t0, sunvec_u, sunvec_up) if (retval /= 0) then - print *, 'Error in FIDAInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAInit, retval = ', retval, '; halting' + stop 1 end if retval = FIDASStolerances(idas_mem, rtol, atol) if (retval /= 0) then - print *, 'Error in FIDASStolerances, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASStolerances, retval = ', retval, '; halting' + stop 1 end if ! Create the linear solver SUNLinSol_SPGMR with left preconditioning ! and the default Krylov dimension sunlinsol_LS => FSUNLinSol_SPGMR(sunvec_u, SUN_PREC_LEFT, 0, sunctx) if (.not. associated(sunlinsol_LS)) then - print *, 'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! IDA recommends allowing up to 5 restarts (default is 0) retval = FSUNLinSol_SPGMRSetMaxRestarts(sunlinsol_LS, 5) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' + stop 1 end if ! Attach the linear solver (will NULL SUNMatrix object) sunmat_A => null() retval = FIDASetLinearSolver(idas_mem, sunlinsol_LS, sunmat_A) if (retval /= 0) then - print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! Set the preconditioner solve and setup functions */ retval = FIDASetPreconditioner(idas_mem, c_funloc(PsetupHeat), c_funloc(PsolveHeat)) if (retval /= 0) then - print *, 'Error in FIDASetPreconditioner, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDASetPreconditioner, retval = ', retval, '; halting' + stop 1 end if ! Print output heading @@ -360,33 +358,33 @@ program main ! Loop over output times, call IDASolve, and print results tout = t1 - do iout = 1,NOUT - retval = FIDASolve(idas_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) - if (retval < 0) then - print *, 'Error in FIDASolve, retval = ', retval, '; halting' - stop 1 - end if - call PrintOutput(idas_mem, tret(1), uu) - tout = 2.d0*tout + do iout = 1, NOUT + retval = FIDASolve(idas_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) + if (retval < 0) then + print *, 'Error in FIDASolve, retval = ', retval, '; halting' + stop 1 + end if + call PrintOutput(idas_mem, tret(1), uu) + tout = 2.d0*tout end do ! Print remaining counters retval = FIDAGetNumErrTestFails(idas_mem, netf) if (retval /= 0) then - print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvConvFails(idas_mem, ncfn) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinConvFails(idas_mem, ncfl) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if print *, " " @@ -406,14 +404,14 @@ program main retval = FIDAReInit(idas_mem, t0, sunvec_u, sunvec_up) if (retval /= 0) then - print *, 'Error in FIDAReInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAReInit, retval = ', retval, '; halting' + stop 1 end if retval = FSUNLinSol_SPGMRSetGSType(sunlinsol_LS, SUN_CLASSICAL_GS) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetGSType, retval = ', retval, '; halting' + stop 1 end if ! Print case number, output table heading, and initial line of table @@ -429,34 +427,34 @@ program main ! Loop over output times, call IDASolve, and print results tout = t1 - do iout = 1,NOUT - retval = FIDASolve(idas_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) - if (retval < 0) then - print *, 'Error in FIDASolve, retval = ', retval, '; halting' - stop 1 - end if - call PrintOutput(idas_mem, tret(1), uu) - tout = 2.d0*tout + do iout = 1, NOUT + retval = FIDASolve(idas_mem, tout, tret, sunvec_u, sunvec_up, IDA_NORMAL) + if (retval < 0) then + print *, 'Error in FIDASolve, retval = ', retval, '; halting' + stop 1 + end if + call PrintOutput(idas_mem, tret(1), uu) + tout = 2.d0*tout end do ! Print remaining counters retval = FIDAGetNumErrTestFails(idas_mem, netf) if (retval /= 0) then - print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumErrTestFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvConvFails(idas_mem, ncfn) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvConvFails, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinConvFails(idas_mem, ncfl) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if print *, " " @@ -475,7 +473,6 @@ program main end program main - ! ---------------------------------------------------------------- ! SetInitialProfile: routine to initialize u and up vectors. ! ---------------------------------------------------------------- @@ -495,9 +492,9 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) type(N_Vector) :: sunvec_r ! residual N_Vector ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: uu(:,:) - real(c_double), pointer :: up(:,:) - real(c_double), pointer :: r(:,:) + real(c_double), pointer :: uu(:, :) + real(c_double), pointer :: up(:, :) + real(c_double), pointer :: r(:, :) ! local variables integer(c_int64_t) :: i, j @@ -509,17 +506,17 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) ! get data arrays from SUNDIALS vectors uu(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_u) up(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_up) - r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) + r(1:mgrid, 1:mgrid) => FN_VGetArrayPointer(sunvec_r) !======= Internals ============ ! Initialize uu on all grid points - do j = 1,mgrid - yfact = dx * (j-1) - do i = 1,mgrid - xfact = dx * (i-1) - uu(i,j) = 16.d0 * xfact * (1.d0 - xfact) * yfact * (1.d0 - yfact) - end do + do j = 1, mgrid + yfact = dx*(j - 1) + do i = 1, mgrid + xfact = dx*(i - 1) + uu(i, j) = 16.d0*xfact*(1.d0 - xfact)*yfact*(1.d0 - yfact) + end do end do ! Initialize up vector to 0 @@ -532,15 +529,14 @@ subroutine SetInitialProfile(sunvec_u, sunvec_up, sunvec_r) up = -r ! Set up at boundary points to zero - up(1,:) = 0.d0 - up(mgrid,:) = 0.d0 - up(:,1) = 0.d0 - up(:,mgrid) = 0.d0 + up(1, :) = 0.d0 + up(mgrid, :) = 0.d0 + up(:, 1) = 0.d0 + up(:, mgrid) = 0.d0 return end subroutine SetInitialProfile - ! ---------------------------------------------------------------- ! PrintHeader: prints first lines of output (problem description) ! ---------------------------------------------------------------- @@ -563,16 +559,15 @@ subroutine PrintHeader(rtol, atol) print *, " Discretized heat equation on 2D unit square." print *, " Zero boundary conditions, polynomial initial conditions." print '(2(a,i2),a,i3)', " Mesh dimensions: ", mgrid, " x ", mgrid, & - " Total system size: ", neq + " Total system size: ", neq print *, " " - print '(2(a,f5.3))', "Tolerance parameters: rtol = ", rtol," atol = ", atol + print '(2(a,f5.3))', "Tolerance parameters: rtol = ", rtol, " atol = ", atol print *, "Constraints set to force all solution components >= 0." print *, "Linear solver: SPGMR, preconditioner using diagonal elements." return end subroutine PrintHeader - ! ---------------------------------------------------------------- ! PrintOutput ! ---------------------------------------------------------------- @@ -588,7 +583,7 @@ subroutine PrintOutput(idas_mem, t, uu) ! calling variable type(c_ptr) :: idas_mem - real(c_double) :: t, uu(mgrid,mgrid) + real(c_double) :: t, uu(mgrid, mgrid) ! internal variables integer(c_int) :: retval, kused(1) @@ -601,66 +596,65 @@ subroutine PrintOutput(idas_mem, t, uu) retval = FIDAGetLastOrder(idas_mem, kused) if (retval /= 0) then - print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastOrder, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumSteps(idas_mem, nst) if (retval /= 0) then - print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumSteps, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumNonlinSolvIters(idas_mem, nni) if (retval /= 0) then - print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumResEvals(idas_mem, nre) if (retval /= 0) then - print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetLastStep(idas_mem, hused) if (retval /= 0) then - print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetLastStep, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumJtimesEvals(idas_mem, nje) if (retval /= 0) then - print *, 'Error in FIDAGetNumJtimesEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumJtimesEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinIters(idas_mem, nli) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinIters, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumLinResEvals(idas_mem, nreLS) if (retval /= 0) then - print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumLinResEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumPrecEvals(idas_mem, npe) if (retval /= 0) then - print *, 'Error in FIDAGetNumPrecEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumPrecEvals, retval = ', retval, '; halting' + stop 1 end if retval = FIDAGetNumPrecSolves(idas_mem, nps) if (retval /= 0) then - print *, 'Error in FIDAGetNumPrecSolves, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FIDAGetNumPrecSolves, retval = ', retval, '; halting' + stop 1 end if - print '(f5.2,1x,es13.5,1x,i1,2x,3(i3,2x),2(i4,2x),es9.2,2x,2(i3,1x))', & - t, umax, kused, nst, nni, nje, nre, nreLS, hused(1), npe, nps + t, umax, kused, nst, nni, nje, nre, nreLS, hused(1), npe, nps end subroutine PrintOutput diff --git a/examples/kinsol/F2003_parallel/kin_diagon_kry_f2003.f90 b/examples/kinsol/F2003_parallel/kin_diagon_kry_f2003.f90 index e0fba580a1..9233fe7b4c 100644 --- a/examples/kinsol/F2003_parallel/kin_diagon_kry_f2003.f90 +++ b/examples/kinsol/F2003_parallel/kin_diagon_kry_f2003.f90 @@ -42,12 +42,12 @@ module kinDiagonKry_mod integer(c_int64_t) :: i, nlocal real(c_double), pointer, dimension(neq) :: u(:), scale(:), constr(:) real(c_double) :: p(neq) - integer(c_int), parameter :: prectype = 2 - integer(c_int), parameter :: maxl = 10 - integer(c_int), parameter :: maxlrst = 2 + integer(c_int), parameter :: prectype = 2 + integer(c_int), parameter :: maxl = 10 + integer(c_int), parameter :: maxlrst = 2 integer(c_long), parameter :: msbpre = 5 - real(c_double), parameter :: fnormtol = 1.0d-5 - real(c_double), parameter :: scsteptol = 1.0d-4 + real(c_double), parameter :: fnormtol = 1.0d-5 + real(c_double), parameter :: scsteptol = 1.0d-4 ! MPI domain decomposition information integer, target :: comm ! communicator object @@ -75,16 +75,16 @@ subroutine init(sunvec_u, sunvec_s, sunvec_c) ! local variables integer(c_int64_t) :: ii - u(1:nlocal) => FN_VGetArrayPointer(sunvec_u) - scale(1:nlocal) => FN_VGetArrayPointer(sunvec_s) + u(1:nlocal) => FN_VGetArrayPointer(sunvec_u) + scale(1:nlocal) => FN_VGetArrayPointer(sunvec_s) constr(1:nlocal) => FN_VGetArrayPointer(sunvec_c) ! ------------------------- ! Set initial guess, and disable scaling - do i = 1,nlocal - ii = i + myid * nlocal - u(i) = 2.0d0 * dble(ii) + do i = 1, nlocal + ii = i + myid*nlocal + u(i) = 2.0d0*dble(ii) end do scale = 1.0d0 constr = 0.0d0 @@ -101,7 +101,7 @@ end subroutine init ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function func(sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use fsundials_core_mod @@ -127,15 +127,14 @@ integer(c_int) function func(sunvec_u, sunvec_f, user_data) & ff(1:nlocal) => FN_VGetArrayPointer(sunvec_f) ! loop over domain, computing our system f(u) = 0 - do i = 1,nlocal - ! set local variables - ii = i + myid * nlocal + do i = 1, nlocal + ! set local variables + ii = i + myid*nlocal - ! applying the constraint f(u) = u(i)^2 - i^2 - ff(i) = uu(i)*uu(i) - dble(ii*ii) + ! applying the constraint f(u) = u(i)^2 - i^2 + ff(i) = uu(i)*uu(i) - dble(ii*ii) end do - ! return success ierr = 0 return @@ -152,7 +151,7 @@ end function func ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function kpsetup(sunvec_u, sunvec_s, sunvec_f, & - sunvec_fs, user_data) result(ierr) bind(C) + sunvec_fs, user_data) result(ierr) bind(C) !======= Inclusions =========== use fsundials_core_mod @@ -176,13 +175,12 @@ integer(c_int) function kpsetup(sunvec_u, sunvec_s, sunvec_f, & udata(1:nlocal) => FN_VGetArrayPointer(sunvec_u) ! loop over domain - do i = 1,nlocal + do i = 1, nlocal - ! setup preconditioner - p(i) = 0.5d0 / (udata(i) + 5.0d0) + ! setup preconditioner + p(i) = 0.5d0/(udata(i) + 5.0d0) end do - ! return success ierr = 0 return @@ -199,7 +197,7 @@ end function kpsetup ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function kpsolve(sunvec_u, sunvec_s, sunvec_f, & - sunvec_fs, sunvec_v, user_data) result(ierr) bind(C) + sunvec_fs, sunvec_v, user_data) result(ierr) bind(C) !======= Inclusions =========== use fsundials_core_mod @@ -223,13 +221,12 @@ integer(c_int) function kpsolve(sunvec_u, sunvec_s, sunvec_f, & v(1:nlocal) => FN_VGetArrayPointer(sunvec_v) ! loop over domain - do i = 1,nlocal + do i = 1, nlocal - ! preconditioner solver - v(i) = v(i) * p(i) + ! preconditioner solver + v(i) = v(i)*p(i) end do - ! return success ierr = 0 return @@ -240,7 +237,6 @@ end function kpsolve end module kinDiagonKry_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -260,10 +256,10 @@ program main real(c_double) :: ftol type(c_ptr) :: sunctx ! sundials context - type(N_Vector), pointer :: sunvec_u ! sundials vectors - type(N_Vector), pointer :: sunvec_s ! sundials vectors - type(N_Vector), pointer :: sunvec_c ! sundials vectors - type(SUNMatrix), pointer :: sunmat_J ! sundials matrix + type(N_Vector), pointer :: sunvec_u ! sundials vectors + type(N_Vector), pointer :: sunvec_s ! sundials vectors + type(N_Vector), pointer :: sunvec_c ! sundials vectors + type(SUNMatrix), pointer :: sunmat_J ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: kmem ! KINSOL memory @@ -280,22 +276,22 @@ program main ! initialize MPI call MPI_Init(ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Init = ", ierr - stop 1 + write (0, *) "Error in MPI_Init = ", ierr + stop 1 end if call MPI_Comm_size(comm, nprocs, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_size = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_size = ", ierr + call MPI_Abort(comm, 1, ierr) end if if (popcnt(nprocs) /= 1 .or. nprocs > neq) then - write(0,*) "Error nprocs must equal a power of 2^n <= neq for functionality." - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error nprocs must equal a power of 2^n <= neq for functionality." + call MPI_Abort(comm, 1, ierr) end if call MPI_Comm_rank(comm, myid, ierr) if (ierr /= MPI_SUCCESS) then - write(0,*) "Error in MPI_Comm_rank = ", ierr - call MPI_Abort(comm, 1, ierr) + write (0, *) "Error in MPI_Comm_rank = ", ierr + call MPI_Abort(comm, 1, ierr) end if outproc = (myid == 0) @@ -303,27 +299,27 @@ program main ! Print problem description if (outproc) then - print *, " " - print *, "Example program kinDiagon_kry_f2003:" - print *, " This FKINSOL example solves a 128 eqn diagonal algebraic system." - print *, " Its purpose is to demonstrate the use of the Fortran interface in" - print *, " a parallel environment." - print *, " " - print *, "Solution method: KIN_none" - print '(a,i3)', "Problem size: neq = ", neq - print '(a,i3)', "Number of procs: nprocs = ", nprocs + print *, " " + print *, "Example program kinDiagon_kry_f2003:" + print *, " This FKINSOL example solves a 128 eqn diagonal algebraic system." + print *, " Its purpose is to demonstrate the use of the Fortran interface in" + print *, " a parallel environment." + print *, " " + print *, "Solution method: KIN_none" + print '(a,i3)', "Problem size: neq = ", neq + print '(a,i3)', "Number of procs: nprocs = ", nprocs end if ! ------------------------- retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) if (retval /= 0) then - print *, 'ERROR in FSUNContext_Create' - stop 1 + print *, 'ERROR in FSUNContext_Create' + stop 1 end if ! ------------------------- ! Create vectors for solution and scales - nlocal = neq / nprocs + nlocal = neq/nprocs sunvec_u => FN_VNew_Parallel(comm, nlocal, neq, sunctx) sunvec_s => FN_VNew_Parallel(comm, nlocal, neq, sunctx) @@ -336,16 +332,16 @@ program main kmem = FKINCreate(sunctx) if (.not. c_associated(kmem)) then - print *, 'ERROR: kmem = NULL' - stop 1 + print *, 'ERROR: kmem = NULL' + stop 1 end if ! sunvec_u is used as a template retval = FKINInit(kmem, c_funloc(func), sunvec_u) if (retval /= 0) then - print *, 'Error in FKINInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINInit, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -353,27 +349,27 @@ program main retval = FKINSetMaxSetupCalls(kmem, msbpre) if (retval /= 0) then - print *, 'Error in FKINSetMaxSetupCalls, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetMaxSetupCalls, retval = ', retval, '; halting' + stop 1 end if ftol = fnormtol retval = FKINSetFuncNormTol(kmem, ftol) if (retval /= 0) then - print *, 'Error in FKINSetFuncNormTol, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetFuncNormTol, retval = ', retval, '; halting' + stop 1 end if retval = FKINSetScaledStepTol(kmem, scsteptol) if (retval /= 0) then - print *, 'Error in FKINSetScaledStepTol, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetScaledStepTol, retval = ', retval, '; halting' + stop 1 end if retval = FKINSetConstraints(kmem, sunvec_c) if (retval /= 0) then - print *, 'Error in FKINSetConstraints, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetConstraints, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -381,8 +377,8 @@ program main sunlinsol_LS => FSUNLinSol_SPGMR(sunvec_u, prectype, maxl, sunctx) if (.not. associated(sunlinsol_LS)) then - print *,'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! ------------------------- @@ -392,8 +388,8 @@ program main retval = FKINSetLinearSolver(kmem, sunlinsol_LS, sunmat_J) if (retval /= 0) then - print *, 'Error in FKINSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -401,8 +397,8 @@ program main retval = FSUNLinSol_SPGMRSetMaxRestarts(sunlinsol_LS, maxlrst) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -410,8 +406,8 @@ program main retval = FKINSetPreconditioner(kmem, c_funloc(kpsetup), c_funloc(kpsolve)) if (retval /= 0) then - print *, 'Error in FKINSetPreconditioner, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetPreconditioner, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -425,21 +421,21 @@ program main retval = FKINSol(kmem, sunvec_u, KIN_NONE, sunvec_s, sunvec_s) if (retval /= 0) then - print *, 'Error in FKINSol, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSol, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- ! Print solution and solver statistics if (outproc) then - print *, " " + print *, " " end if - do nprint = 0,nprocs-1 - if (nprint == myid) then - call PrintOutput(u) - end if - call MPI_Barrier(comm, ierr) + do nprint = 0, nprocs - 1 + if (nprint == myid) then + call PrintOutput(u) + end if + call MPI_Barrier(comm, ierr) end do call MPI_Barrier(comm, ierr) call PrintFinalStats(kmem, outproc) @@ -457,7 +453,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput: prints solution at selected points ! ---------------------------------------------------------------- @@ -475,9 +470,9 @@ subroutine PrintOutput(uu) !======= Internals ============ - do i = 1,nlocal,4 - ii = i + nlocal * myid - print '(i4, 4(1x, f10.6))', ii, uu(i), uu(i+1), uu(i+2), uu(i+3) + do i = 1, nlocal, 4 + ii = i + nlocal*myid + print '(i4, 4(1x, f10.6))', ii, uu(i), uu(i + 1), uu(i + 2), uu(i + 3) end do return @@ -485,7 +480,6 @@ subroutine PrintOutput(uu) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -501,7 +495,7 @@ subroutine PrintFinalStats(kmemo, outproc) implicit none type(c_ptr), intent(in) :: kmemo - logical, intent(in) :: outproc + logical, intent(in) :: outproc integer(c_int) :: retval integer(c_long) :: nni(1), nli(1), nfe(1), npe(1), nps(1), ncfl(1) @@ -512,47 +506,47 @@ subroutine PrintFinalStats(kmemo, outproc) retval = FKINGetNumNonlinSolvIters(kmemo, nni) if (retval /= 0) then - print *, 'Error in FKINGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumLinIters(kmemo, nli) if (retval /= 0) then - print *, 'Error in FKINGetNumLinIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINGetNumLinIters, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumFuncEvals(kmemo, nfe) if (retval /= 0) then - print *, 'Error in FKINGetNumFuncEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINGetNumFuncEvals, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumPrecEvals(kmemo, npe) if (retval /= 0) then - print *, 'Error in KINGetNumPrecEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in KINGetNumPrecEvals, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumPrecSolves(kmemo, nps) if (retval /= 0) then - print *, 'Error in KINGetNumPrecSolves, retval = ', retval, '; halting' - stop 1 + print *, 'Error in KINGetNumPrecSolves, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumLinConvFails(kmemo, ncfl) if (retval /= 0) then - print *, 'Error in KINGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in KINGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if if (outproc) then - print *, ' ' - print *, 'Final Statistics..' - print *, ' ' - print '(2(A,i6))' ,'nni =', nni, ' nli =', nli - print '(2(A,i6))' ,'nfe =', nfe, ' npe =', npe - print '(2(A,i6))' ,'nps =', nps, ' nlcf =', ncfl + print *, ' ' + print *, 'Final Statistics..' + print *, ' ' + print '(2(A,i6))', 'nni =', nni, ' nli =', nli + print '(2(A,i6))', 'nfe =', nfe, ' npe =', npe + print '(2(A,i6))', 'nps =', nps, ' nlcf =', ncfl end if return diff --git a/examples/kinsol/F2003_serial/kinDiagon_kry_f2003.f90 b/examples/kinsol/F2003_serial/kinDiagon_kry_f2003.f90 index 78c76cde4f..43eab280d1 100644 --- a/examples/kinsol/F2003_serial/kinDiagon_kry_f2003.f90 +++ b/examples/kinsol/F2003_serial/kinDiagon_kry_f2003.f90 @@ -50,12 +50,12 @@ module kinDiagonKry_mod integer(c_int64_t) :: i real(c_double), pointer, dimension(neq) :: u(:), scale(:), constr(:) real(c_double) :: p(neq) - integer(c_int), parameter :: prectype = 2 - integer(c_int), parameter :: maxl = 10 - integer(c_int), parameter :: maxlrst = 2 + integer(c_int), parameter :: prectype = 2 + integer(c_int), parameter :: maxl = 10 + integer(c_int), parameter :: maxlrst = 2 integer(c_long), parameter :: msbpre = 5 - real(c_double), parameter :: fnormtol = 1.0d-5 - real(c_double), parameter :: scsteptol = 1.0d-4 + real(c_double), parameter :: fnormtol = 1.0d-5 + real(c_double), parameter :: scsteptol = 1.0d-4 contains @@ -72,15 +72,15 @@ subroutine init(sunvec_u, sunvec_s, sunvec_c) type(N_Vector) :: sunvec_s ! scaling N_Vector type(N_Vector) :: sunvec_c ! constraint N_Vector - u(1:neq) => FN_VGetArrayPointer(sunvec_u) - scale(1:neq) => FN_VGetArrayPointer(sunvec_s) + u(1:neq) => FN_VGetArrayPointer(sunvec_u) + scale(1:neq) => FN_VGetArrayPointer(sunvec_s) constr(1:neq) => FN_VGetArrayPointer(sunvec_c) ! ------------------------- ! Set initial guess, and disable scaling - do i = 1,neq - u(i) = 2.0d0 * dble(i) + do i = 1, neq + u(i) = 2.0d0*dble(i) end do scale = 1.0d0 constr = 0.0d0 @@ -97,7 +97,7 @@ end subroutine init ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function func(sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Declarations ========= implicit none @@ -117,13 +117,12 @@ integer(c_int) function func(sunvec_u, sunvec_f, user_data) & ff(1:neq) => FN_VGetArrayPointer(sunvec_f) ! loop over domain, computing our system f(u) = 0 - do i = 1,neq + do i = 1, neq - ! applying the constraint f(u) = u(i)^2 - i^2 - ff(i) = uu(i)*uu(i) - dble(i*i) + ! applying the constraint f(u) = u(i)^2 - i^2 + ff(i) = uu(i)*uu(i) - dble(i*i) end do - ! return success ierr = 0 return @@ -140,7 +139,7 @@ end function func ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function kpsetup(sunvec_u, sunvec_s, sunvec_f, & - sunvec_fs, user_data) result(ierr) bind(C) + sunvec_fs, user_data) result(ierr) bind(C) !======= Declarations ========= implicit none @@ -161,13 +160,12 @@ integer(c_int) function kpsetup(sunvec_u, sunvec_s, sunvec_f, & udata(1:neq) => FN_VGetArrayPointer(sunvec_u) ! loop over domain - do i = 1,neq + do i = 1, neq - ! setup preconditioner - p(i) = 0.5d0 / (udata(i) + 5.0d0) + ! setup preconditioner + p(i) = 0.5d0/(udata(i) + 5.0d0) end do - ! return success ierr = 0 return @@ -184,7 +182,7 @@ end function kpsetup ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function kpsolve(sunvec_u, sunvec_s, sunvec_f, & - sunvec_fs, sunvec_v, user_data) result(ierr) bind(C) + sunvec_fs, sunvec_v, user_data) result(ierr) bind(C) !======= Declarations ========= implicit none @@ -205,13 +203,12 @@ integer(c_int) function kpsolve(sunvec_u, sunvec_s, sunvec_f, & v(1:neq) => FN_VGetArrayPointer(sunvec_v) ! loop over domain - do i = 1,neq + do i = 1, neq - ! preconditioner solver - v(i) = v(i) * p(i) + ! preconditioner solver + v(i) = v(i)*p(i) end do - ! return success ierr = 0 return @@ -222,7 +219,6 @@ end function kpsolve end module kinDiagonKry_mod ! ------------------------------------------------------------------ - ! ------------------------------------------------------------------ ! Main driver program ! ------------------------------------------------------------------ @@ -241,10 +237,10 @@ program main real(c_double) :: ftol type(c_ptr) :: sunctx ! sundials context - type(N_Vector), pointer :: sunvec_u ! sundials vectors - type(N_Vector), pointer :: sunvec_s ! sundials vectors - type(N_Vector), pointer :: sunvec_c ! sundials vectors - type(SUNMatrix), pointer :: sunmat_J ! sundials matrix + type(N_Vector), pointer :: sunvec_u ! sundials vectors + type(N_Vector), pointer :: sunvec_s ! sundials vectors + type(N_Vector), pointer :: sunvec_c ! sundials vectors + type(SUNMatrix), pointer :: sunmat_J ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: kmem ! KINSOL memory @@ -266,8 +262,8 @@ program main ! ------------------------- retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) if (retval /= 0) then - print *, 'ERROR in FSUNContext_Create' - stop 1 + print *, 'ERROR in FSUNContext_Create' + stop 1 end if ! ------------------------- @@ -284,16 +280,16 @@ program main kmem = FKINCreate(sunctx) if (.not. c_associated(kmem)) then - print *, 'ERROR: kmem = NULL' - stop 1 + print *, 'ERROR: kmem = NULL' + stop 1 end if ! sunvec_u is used as a template retval = FKINInit(kmem, c_funloc(func), sunvec_u) if (retval /= 0) then - print *, 'Error in FKINInit, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINInit, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -301,27 +297,27 @@ program main retval = FKINSetMaxSetupCalls(kmem, msbpre) if (retval /= 0) then - print *, 'Error in FKINSetMaxSetupCalls, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetMaxSetupCalls, retval = ', retval, '; halting' + stop 1 end if ftol = fnormtol retval = FKINSetFuncNormTol(kmem, ftol) if (retval /= 0) then - print *, 'Error in FKINSetFuncNormTol, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetFuncNormTol, retval = ', retval, '; halting' + stop 1 end if retval = FKINSetScaledStepTol(kmem, scsteptol) if (retval /= 0) then - print *, 'Error in FKINSetScaledStepTol, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetScaledStepTol, retval = ', retval, '; halting' + stop 1 end if retval = FKINSetConstraints(kmem, sunvec_c) if (retval /= 0) then - print *, 'Error in FKINSetConstraints, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetConstraints, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -329,8 +325,8 @@ program main sunlinsol_LS => FSUNLinSol_SPGMR(sunvec_u, prectype, maxl, sunctx) if (.not. associated(sunlinsol_LS)) then - print *,'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! ------------------------- @@ -340,8 +336,8 @@ program main retval = FKINSetLinearSolver(kmem, sunlinsol_LS, sunmat_J) if (retval /= 0) then - print *, 'Error in FKINSetLinearSolver, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetLinearSolver, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -349,8 +345,8 @@ program main retval = FSUNLinSol_SPGMRSetMaxRestarts(sunlinsol_LS, maxlrst) if (retval /= 0) then - print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FSUNLinSol_SPGMRSetMaxRestarts, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -358,8 +354,8 @@ program main retval = FKINSetPreconditioner(kmem, c_funloc(kpsetup), c_funloc(kpsolve)) if (retval /= 0) then - print *, 'Error in FKINSetPreconditioner, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSetPreconditioner, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -373,8 +369,8 @@ program main retval = FKINSol(kmem, sunvec_u, KIN_NONE, sunvec_s, sunvec_s) if (retval /= 0) then - print *, 'Error in FKINSol, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINSol, retval = ', retval, '; halting' + stop 1 end if ! ------------------------- @@ -395,7 +391,6 @@ program main end program main ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintOutput: prints solution at selected points ! ---------------------------------------------------------------- @@ -412,8 +407,8 @@ subroutine PrintOutput(uu) !======= Internals ============ - do i = 1,neq,4 - print '(i4, 4(1x, f10.6))', i, uu(i), uu(i+1), uu(i+2), uu(i+3) + do i = 1, neq, 4 + print '(i4, 4(1x, f10.6))', i, uu(i), uu(i + 1), uu(i + 2), uu(i + 3) end do return @@ -421,7 +416,6 @@ subroutine PrintOutput(uu) end subroutine PrintOutput ! ---------------------------------------------------------------- - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -447,46 +441,46 @@ subroutine PrintFinalStats(kmemo) retval = FKINGetNumNonlinSolvIters(kmemo, nni) if (retval /= 0) then - print *, 'Error in FKINGetNumNonlinSolvIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINGetNumNonlinSolvIters, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumLinIters(kmemo, nli) if (retval /= 0) then - print *, 'Error in FKINGetNumLinIters, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINGetNumLinIters, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumFuncEvals(kmemo, nfe) if (retval /= 0) then - print *, 'Error in FKINGetNumFuncEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in FKINGetNumFuncEvals, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumPrecEvals(kmemo, npe) if (retval /= 0) then - print *, 'Error in KINGetNumPrecEvals, retval = ', retval, '; halting' - stop 1 + print *, 'Error in KINGetNumPrecEvals, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumPrecSolves(kmemo, nps) if (retval /= 0) then - print *, 'Error in KINGetNumPrecSolves, retval = ', retval, '; halting' - stop 1 + print *, 'Error in KINGetNumPrecSolves, retval = ', retval, '; halting' + stop 1 end if retval = FKINGetNumLinConvFails(kmemo, ncfl) if (retval /= 0) then - print *, 'Error in KINGetNumLinConvFails, retval = ', retval, '; halting' - stop 1 + print *, 'Error in KINGetNumLinConvFails, retval = ', retval, '; halting' + stop 1 end if print *, ' ' print *, 'Final Statistics..' print *, ' ' - print '(2(A,i6))' ,'nni =', nni, ' nli =', nli - print '(2(A,i6))' ,'nfe =', nfe, ' npe =', npe - print '(2(A,i6))' ,'nps =', nps, ' nlcf =', ncfl + print '(2(A,i6))', 'nni =', nni, ' nli =', nli + print '(2(A,i6))', 'nfe =', nfe, ' npe =', npe + print '(2(A,i6))', 'nps =', nps, ' nlcf =', ncfl return diff --git a/examples/kinsol/F2003_serial/kinLaplace_bnd_f2003.f90 b/examples/kinsol/F2003_serial/kinLaplace_bnd_f2003.f90 index 4cdf270c9b..ccd4510591 100644 --- a/examples/kinsol/F2003_serial/kinLaplace_bnd_f2003.f90 +++ b/examples/kinsol/F2003_serial/kinLaplace_bnd_f2003.f90 @@ -35,7 +35,7 @@ module prob_mod integer(c_int64_t), parameter :: ny = 31 integer(c_int64_t), parameter :: neq = nx*ny integer(c_int64_t), parameter :: skip = 3 - real(c_double), parameter :: ftol = 1.d-12 + real(c_double), parameter :: ftol = 1.d-12 contains @@ -48,7 +48,7 @@ module prob_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function func(sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -60,10 +60,10 @@ integer(c_int) function func(sunvec_u, sunvec_f, user_data) & ! calling variables type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: u(:,:), f(:,:) + real(c_double), pointer :: u(:, :), f(:, :) ! internal variables integer(c_int64_t) :: i, j @@ -76,33 +76,33 @@ integer(c_int) function func(sunvec_u, sunvec_f, user_data) & f(1:nx, 1:ny) => FN_VGetArrayPointer(sunvec_f) ! set shortcut constants - dx = 1.d0/(nx+1) - dy = 1.d0/(ny+1) + dx = 1.d0/(nx + 1) + dy = 1.d0/(ny + 1) hdc = 1.d0/(dx*dx) vdc = 1.d0/(dy*dy) ! loop over domain, computing residual - do j = 1,ny - do i = 1,nx - - ! Extract u at x_i, y_j and four neighboring points - uij = u(i,j) - udn = 0.d0 - if (j > 1) udn = u(i,j-1) - uup = 0.d0 - if (j < ny) uup = u(i,j+1) - ult = 0.d0 - if (i > 1) ult = u(i-1,j) - urt = 0.d0 - if (i < nx) urt = u(i+1,j) - - ! Evaluate diffusion components - hdiff = hdc*(ult - 2.d0*uij + urt) - vdiff = vdc*(uup - 2.d0*uij + udn) - - ! Set residual at x_i, y_j - f(i, j) = hdiff + vdiff + uij - uij*uij*uij + 2.d0 - end do + do j = 1, ny + do i = 1, nx + + ! Extract u at x_i, y_j and four neighboring points + uij = u(i, j) + udn = 0.d0 + if (j > 1) udn = u(i, j - 1) + uup = 0.d0 + if (j < ny) uup = u(i, j + 1) + ult = 0.d0 + if (i > 1) ult = u(i - 1, j) + urt = 0.d0 + if (i < nx) urt = u(i + 1, j) + + ! Evaluate diffusion components + hdiff = hdc*(ult - 2.d0*uij + urt) + vdiff = vdc*(uup - 2.d0*uij + udn) + + ! Set residual at x_i, y_j + f(i, j) = hdiff + vdiff + uij - uij*uij*uij + 2.d0 + end do end do ! return success @@ -113,7 +113,6 @@ end function func end module prob_mod - program main !======= Inclusions =========== @@ -134,15 +133,15 @@ program main integer(c_long) :: mset, msubset type(c_ptr) :: sunctx ! sundials context - type(N_Vector), pointer :: sunvec_u ! sundials vectors - type(N_Vector), pointer :: sunvec_s - type(SUNMatrix), pointer :: sunmat_J ! sundials matrix + type(N_Vector), pointer :: sunvec_u ! sundials vectors + type(N_Vector), pointer :: sunvec_s + type(SUNMatrix), pointer :: sunmat_J ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: kmem ! KINSOL memory ! solution and scaling vectors; nx, ny are set in the prob_mod module - real(c_double), dimension(nx,ny) :: u, scale + real(c_double), dimension(nx, ny) :: u, scale !======= Internals ============ @@ -175,14 +174,14 @@ program main sunvec_u => FN_VMake_Serial(neq, u, sunctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_s => FN_VMake_Serial(neq, scale, sunctx) if (.not. associated(sunvec_s)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! ------------------------- @@ -190,16 +189,16 @@ program main kmem = FKINCreate(sunctx) if (.not. c_associated(kmem)) then - print *, 'ERROR: kmem = NULL' - stop 1 + print *, 'ERROR: kmem = NULL' + stop 1 end if ! sunvec_u is used as a template ierr = FKINInit(kmem, c_funloc(func), sunvec_u) if (ierr /= 0) then - print *, 'Error in FKINInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINInit, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -208,8 +207,8 @@ program main fnormtol = ftol ierr = FKINSetFuncNormTol(kmem, fnormtol) if (ierr /= 0) then - print *, 'Error in FKINSetFuncNormTol, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetFuncNormTol, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -217,8 +216,8 @@ program main sunmat_J => FSUNBandMatrix(neq, nx, nx, sunctx) if (.not. associated(sunmat_J)) then - print *,'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! ------------------------- @@ -226,8 +225,8 @@ program main sunlinsol_LS => FSUNLinSol_Band(sunvec_u, sunmat_J, sunctx) if (.not. associated(sunlinsol_LS)) then - print *,'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! ------------------------- @@ -235,8 +234,8 @@ program main ierr = FKINSetLinearSolver(kmem, sunlinsol_LS, sunmat_J) if (ierr /= 0) then - print *, 'Error in FKINSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -246,16 +245,16 @@ program main mset = 100 ierr = FKINSetMaxSetupCalls(kmem, mset) if (ierr /= 0) then - print *, 'Error in FKINSetMaxSetupCalls, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetMaxSetupCalls, ierr = ', ierr, '; halting' + stop 1 end if ! Every msubset iterations, test if a Jacobian evaluation is necessary msubset = 1 ierr = FKINSetMaxSubSetupCalls(kmem, msubset) if (ierr /= 0) then - print *, 'Error in FKINSetMaxSubSetupCalls, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetMaxSubSetupCalls, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -269,8 +268,8 @@ program main ierr = FKINSol(kmem, sunvec_u, KIN_LINESEARCH, sunvec_s, sunvec_s) if (ierr /= 0) then - print *, 'Error in FKINSol, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSol, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -279,11 +278,11 @@ program main ! Get scaled norm of the system function ierr = FKINGetFuncNorm(kmem, fnorm) if (ierr /= 0) then - print *, 'Error in FKINGetFuncNorm, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetFuncNorm, ierr = ', ierr, '; halting' + stop 1 end if print *, " " - print *, "Computed solution (||F|| = ", fnorm,"):" + print *, "Computed solution (||F|| = ", fnorm, "):" print *, " " call PrintOutput(u) call PrintFinalStats(kmem) @@ -298,7 +297,6 @@ program main end program main - ! ---------------------------------------------------------------- ! PrintOutput: prints solution at selected points ! ---------------------------------------------------------------- @@ -312,7 +310,7 @@ subroutine PrintOutput(u) implicit none ! calling variable - real(c_double), dimension(nx,ny) :: u + real(c_double), dimension(nx, ny) :: u ! internal variables integer(c_int64_t) :: i, j @@ -321,30 +319,29 @@ subroutine PrintOutput(u) !======= Internals ============ ! set shortcuts - dx = 1.d0/(nx+1) - dy = 1.d0/(ny+1) + dx = 1.d0/(nx + 1) + dy = 1.d0/(ny + 1) - write(*,'(13x)',advance='no') - do i = 1,nx,skip - x = i*dx - write(*,'(f8.5,1x)',advance='no') x + write (*, '(13x)', advance='no') + do i = 1, nx, skip + x = i*dx + write (*, '(f8.5,1x)', advance='no') x end do print *, " " print *, " " - do j = 1,ny,skip - y = j*dy - write(*,'(f8.5,5x)',advance='no') y - do i = 1,nx,skip - write(*,'(f8.5,1x)',advance='no') u(i,j) - end do - print *, " " + do j = 1, ny, skip + y = j*dy + write (*, '(f8.5,5x)', advance='no') y + do i = 1, nx, skip + write (*, '(f8.5,1x)', advance='no') u(i, j) + end do + print *, " " end do return end subroutine PrintOutput - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -371,73 +368,69 @@ subroutine PrintFinalStats(kmem) ierr = FKINGetNumNonlinSolvIters(kmem, nni) if (ierr /= 0) then - print *, 'Error in FKINGetNumNonlinSolvIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumNonlinSolvIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumFuncEvals(kmem, nfe) if (ierr /= 0) then - print *, 'Error in FKINGetNumFuncEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumFuncEvals, ierr = ', ierr, '; halting' + stop 1 end if - ! Linesearch statistics ierr = FKINGetNumBetaCondFails(kmem, nbcfails) if (ierr /= 0) then - print *, 'Error in FKINGetNumBetaCondFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumBetaCondFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumBacktrackOps(kmem, nbacktr) if (ierr /= 0) then - print *, 'Error in FKINGetNumBacktrackOps, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumBacktrackOps, ierr = ', ierr, '; halting' + stop 1 end if - ! Main solver workspace size ierr = FKINGetWorkSpace(kmem, lenrw, leniw) if (ierr /= 0) then - print *, 'Error in FKINGetWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if - ! Band linear solver statistics ierr = FKINGetNumJacEvals(kmem, nje) if (ierr /= 0) then - print *, 'Error in FKINGetNumJacEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumJacEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumLinFuncEvals(kmem, nfeB) if (ierr /= 0) then - print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' + stop 1 end if - ! Band linear solver workspace size ierr = FKINGetLinWorkSpace(kmem, lenrwB, leniwB) if (ierr /= 0) then - print *, 'Error in FKINGetLinWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetLinWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, 'Final Statistics..' print *, ' ' - print '(2(A,i6))' ,'nni =', nni, ' nfe =', nfe - print '(2(A,i6))' ,'nbcfails =', nbcfails, ' nbacktr =', nbacktr - print '(2(A,i6))' ,'nje =', nje, ' nfeB =', nfeB + print '(2(A,i6))', 'nni =', nni, ' nfe =', nfe + print '(2(A,i6))', 'nbcfails =', nbcfails, ' nbacktr =', nbacktr + print '(2(A,i6))', 'nje =', nje, ' nfeB =', nfeB print *, ' ' - print '(2(A,i6))' ,'lenrw =', lenrw, ' leniw =', leniw - print '(2(A,i6))' ,'lenrwB =', lenrwB, ' leniwB =', leniwB + print '(2(A,i6))', 'lenrw =', lenrw, ' leniw =', leniw + print '(2(A,i6))', 'lenrwB =', lenrwB, ' leniwB =', leniwB return diff --git a/examples/kinsol/F2003_serial/kinLaplace_picard_kry_f2003.f90 b/examples/kinsol/F2003_serial/kinLaplace_picard_kry_f2003.f90 index 9832ac97ff..875359e19e 100644 --- a/examples/kinsol/F2003_serial/kinLaplace_picard_kry_f2003.f90 +++ b/examples/kinsol/F2003_serial/kinLaplace_picard_kry_f2003.f90 @@ -38,7 +38,7 @@ module prob_mod integer(c_int64_t), parameter :: ny = 31 integer(c_int64_t), parameter :: neq = nx*ny integer(c_int64_t), parameter :: skip = 3 - real(c_double), parameter :: ftol = 1.d-12 + real(c_double), parameter :: ftol = 1.d-12 contains @@ -47,22 +47,21 @@ module prob_mod ! ---------------------------------------------------------------- integer(c_int) function func(sunvec_u, sunvec_f, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none ! calling variables type(N_Vector) :: sunvec_u ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: u(:,:), f(:,:) + real(c_double), pointer :: u(:, :), f(:, :) ! internal variables integer(c_int64_t) :: i, j @@ -75,34 +74,34 @@ integer(c_int) function func(sunvec_u, sunvec_f, user_data) & f(1:nx, 1:ny) => FN_VGetArrayPointer(sunvec_f) ! set shortcut constants - dx = 1.d0/(nx+1) - dy = 1.d0/(ny+1) + dx = 1.d0/(nx + 1) + dy = 1.d0/(ny + 1) hdc = 1.d0/(dx*dx) vdc = 1.d0/(dy*dy) ! loop over domain, computing residual - do j = 1,ny - do i = 1,nx - - ! Extract u at x_i, y_j and four neighboring points - uij = u(i,j) - udn = 0.d0 - if (j > 1) udn = u(i,j-1) - uup = 0.d0 - if (j < ny) uup = u(i,j+1) - ult = 0.d0 - if (i > 1) ult = u(i-1,j) - urt = 0.d0 - if (i < nx) urt = u(i+1,j) - - ! Evaluate diffusion components - hdiff = hdc*(ult - 2.d0*uij + urt) - vdiff = vdc*(uup - 2.d0*uij + udn) - - ! Set residual at x_i, y_j - f(i, j) = hdiff + vdiff + uij - uij*uij*uij + 2.d0 - - end do + do j = 1, ny + do i = 1, nx + + ! Extract u at x_i, y_j and four neighboring points + uij = u(i, j) + udn = 0.d0 + if (j > 1) udn = u(i, j - 1) + uup = 0.d0 + if (j < ny) uup = u(i, j + 1) + ult = 0.d0 + if (i > 1) ult = u(i - 1, j) + urt = 0.d0 + if (i < nx) urt = u(i + 1, j) + + ! Evaluate diffusion components + hdiff = hdc*(ult - 2.d0*uij + urt) + vdiff = vdc*(uup - 2.d0*uij + udn) + + ! Set residual at x_i, y_j + f(i, j) = hdiff + vdiff + uij - uij*uij*uij + 2.d0 + + end do end do ! return success @@ -111,18 +110,16 @@ integer(c_int) function func(sunvec_u, sunvec_f, user_data) & end function func - ! ---------------------------------------------------------------- ! Jacobian vector product function ! ---------------------------------------------------------------- integer(c_int) function jactimes(sunvec_v, sunvec_Jv, sunvec_u, new_u, user_data) & - result(ierr) bind(C) + result(ierr) bind(C) !======= Inclusions =========== use, intrinsic :: iso_c_binding - !======= Declarations ========= implicit none @@ -131,10 +128,10 @@ integer(c_int) function jactimes(sunvec_v, sunvec_Jv, sunvec_u, new_u, user_data type(N_Vector) :: sunvec_Jv ! output vector type(N_Vector) :: sunvec_u ! current solution vector integer(c_int) :: new_u ! flag indicating if u has been updated - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors - real(c_double), pointer :: v(:,:), Jv(:,:) + real(c_double), pointer :: v(:, :), Jv(:, :) ! internal variables integer(c_int64_t) :: i, j @@ -143,38 +140,38 @@ integer(c_int) function jactimes(sunvec_v, sunvec_Jv, sunvec_u, new_u, user_data !======= Internals ============ ! get data arrays from SUNDIALS vectors, casting as 2D Fortran arrays - v(1:nx, 1:ny) => FN_VGetArrayPointer(sunvec_v) + v(1:nx, 1:ny) => FN_VGetArrayPointer(sunvec_v) Jv(1:nx, 1:ny) => FN_VGetArrayPointer(sunvec_Jv) ! set shortcut constants - dx = 1.d0/(nx+1) - dy = 1.d0/(ny+1) + dx = 1.d0/(nx + 1) + dy = 1.d0/(ny + 1) hdc = 1.d0/(dx*dx) vdc = 1.d0/(dy*dy) ! loop over domain, computing residual - do j = 1,ny - do i = 1,nx - - ! Extract v at x_i, y_j and four neighboring points - vij = v(i,j) - vdn = 0.d0 - if (j > 1) vdn = v(i,j-1) - vup = 0.d0 - if (j < ny) vup = v(i,j+1) - vlt = 0.d0 - if (i > 1) vlt = v(i-1,j) - vrt = 0.d0 - if (i < nx) vrt = v(i+1,j) - - ! Evaluate diffusion components - hdiff = hdc*(vlt - 2.d0*vij + vrt) - vdiff = vdc*(vup - 2.d0*vij + vdn) - - ! Set residual at x_i, y_j - Jv(i, j) = hdiff + vdiff - - end do + do j = 1, ny + do i = 1, nx + + ! Extract v at x_i, y_j and four neighboring points + vij = v(i, j) + vdn = 0.d0 + if (j > 1) vdn = v(i, j - 1) + vup = 0.d0 + if (j < ny) vup = v(i, j + 1) + vlt = 0.d0 + if (i > 1) vlt = v(i - 1, j) + vrt = 0.d0 + if (i < nx) vrt = v(i + 1, j) + + ! Evaluate diffusion components + hdiff = hdc*(vlt - 2.d0*vij + vrt) + vdiff = vdc*(vup - 2.d0*vij + vdn) + + ! Set residual at x_i, y_j + Jv(i, j) = hdiff + vdiff + + end do end do ! return success @@ -185,7 +182,6 @@ end function jactimes end module prob_mod - program main !======= Inclusions =========== @@ -205,15 +201,15 @@ program main integer(c_long) :: maa = 3 type(c_ptr) :: sunctx - type(N_Vector), pointer :: sunvec_u ! sundials vectors - type(N_Vector), pointer :: sunvec_s - type(SUNMatrix), pointer :: sunmat_L ! sundials matrix (empty) + type(N_Vector), pointer :: sunvec_u ! sundials vectors + type(N_Vector), pointer :: sunvec_s + type(SUNMatrix), pointer :: sunmat_L ! sundials matrix (empty) type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: kmem ! KINSOL memory ! solution and scaling vectors; nx, ny are set in the prob_mod module - real(c_double), dimension(nx,ny) :: u, scale + real(c_double), dimension(nx, ny) :: u, scale !======= Internals ============ @@ -232,7 +228,7 @@ program main ! Set initial guess, and disable scaling u = 0.d0 - u(2,2) = 1.0d0 + u(2, 2) = 1.0d0 scale = 1.d0 ! no scaling used @@ -245,14 +241,14 @@ program main sunvec_u => FN_VMake_Serial(neq, u, sunctx) if (.not. associated(sunvec_u)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_s => FN_VMake_Serial(neq, scale, sunctx) if (.not. associated(sunvec_s)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! ------------------------- @@ -260,23 +256,23 @@ program main kmem = FKINCreate(sunctx) if (.not. c_associated(kmem)) then - print *, 'ERROR: kmem = NULL' - stop 1 + print *, 'ERROR: kmem = NULL' + stop 1 end if ! sunvec_u is used as a template ! Use acceleration with up to 3 prior residuals - ierr = FKINSetMAA(kmem, maa); + ierr = FKINSetMAA(kmem, maa); if (ierr /= 0) then - print *, 'Error in FKINISetMAA, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINISetMAA, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINInit(kmem, c_funloc(func), sunvec_u) if (ierr /= 0) then - print *, 'Error in FKINInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINInit, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -287,8 +283,8 @@ program main fnormtol = ftol ierr = FKINSetFuncNormTol(kmem, fnormtol) if (ierr /= 0) then - print *, 'Error in FKINSetFuncNormTol, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetFuncNormTol, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -296,8 +292,8 @@ program main sunlinsol_LS => FSUNLinSol_SPGMR(sunvec_u, SUN_PREC_NONE, 10, sunctx) if (.not. associated(sunlinsol_LS)) then - print *,'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! ------------------------- @@ -307,17 +303,17 @@ program main ierr = FKINSetLinearSolver(kmem, sunlinsol_LS, sunmat_L) if (ierr /= 0) then - print *, 'Error in FKINSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- ! Set Jacobian vector product function - ierr = FKINSetJacTimesVecFn(kmem, c_funloc(jactimes)); + ierr = FKINSetJacTimesVecFn(kmem, c_funloc(jactimes)); if (ierr /= 0) then - print *, 'Error in FKINSetJacTimesVecFn, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetJacTimesVecFn, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -331,8 +327,8 @@ program main ierr = FKINSol(kmem, sunvec_u, KIN_PICARD, sunvec_s, sunvec_s) if (ierr /= 0) then - print *, 'Error in FKINSol, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSol, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -341,11 +337,11 @@ program main ! Get scaled norm of the system function ierr = FKINGetFuncNorm(kmem, fnorm) if (ierr /= 0) then - print *, 'Error in FKINGetFuncNorm, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetFuncNorm, ierr = ', ierr, '; halting' + stop 1 end if print *, " " - print '(A,ES12.5,A)', "Computed solution (||F|| = ", fnorm,"):" + print '(A,ES12.5,A)', "Computed solution (||F|| = ", fnorm, "):" print *, " " call PrintOutput(u) call PrintFinalStats(kmem) @@ -359,7 +355,6 @@ program main end program main - ! ---------------------------------------------------------------- ! PrintOutput: prints solution at selected points ! ---------------------------------------------------------------- @@ -373,7 +368,7 @@ subroutine PrintOutput(u) implicit none ! calling variable - real(c_double), dimension(nx,ny) :: u + real(c_double), dimension(nx, ny) :: u ! internal variables integer(c_int64_t) :: i, j @@ -382,30 +377,29 @@ subroutine PrintOutput(u) !======= Internals ============ ! set shortcuts - dx = 1.d0/(nx+1) - dy = 1.d0/(ny+1) + dx = 1.d0/(nx + 1) + dy = 1.d0/(ny + 1) - write(*,'(11x)',advance='no') - do i = 1,nx,skip - x = i*dx - write(*,'(f8.5,1x)',advance='no') x + write (*, '(11x)', advance='no') + do i = 1, nx, skip + x = i*dx + write (*, '(f8.5,1x)', advance='no') x end do print *, " " print *, " " - do j = 1,ny,skip - y = j*dy - write(*,'(f7.5,4x)',advance='no') y - do i = 1,nx,skip - write(*,'(f8.5,1x)',advance='no') u(i,j) - end do - print *, " " + do j = 1, ny, skip + y = j*dy + write (*, '(f7.5,4x)', advance='no') y + do i = 1, nx, skip + write (*, '(f8.5,1x)', advance='no') u(i, j) + end do + print *, " " end do return end subroutine PrintOutput - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -432,79 +426,79 @@ subroutine PrintFinalStats(kmem) ierr = FKINGetNumNonlinSolvIters(kmem, nni) if (ierr /= 0) then - print *, 'Error in FKINGetNumNonlinSolvIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumNonlinSolvIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumFuncEvals(kmem, nfe) if (ierr /= 0) then - print *, 'Error in FKINGetNumFuncEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumFuncEvals, ierr = ', ierr, '; halting' + stop 1 end if ! Linear solver statistics ierr = FKINGetNumLinIters(kmem, nli) if (ierr /= 0) then - print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumLinFuncEvals(kmem, nfeLS) if (ierr /= 0) then - print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumLinConvFails(kmem, ncfl) if (ierr /= 0) then - print *, 'Error in FKINGetNumLinConvFails, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumLinConvFails, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumJtimesEvals(kmem, njvevals) if (ierr /= 0) then - print *, 'Error in FKINGetNumJtimesEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumJtimesEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumPrecEvals(kmem, npe) if (ierr /= 0) then - print *, 'Error in FKINGetNumPrecEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumPrecEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumPrecSolves(kmem, nps) if (ierr /= 0) then - print *, 'Error in FKINGetNumPrecSolves, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumPrecSolves, ierr = ', ierr, '; halting' + stop 1 end if ! Main solver workspace size ierr = FKINGetWorkSpace(kmem, lenrw, leniw) if (ierr /= 0) then - print *, 'Error in FKINGetWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if ! Linear solver workspace size ierr = FKINGetLinWorkSpace(kmem, lenrwLS, leniwLS) if (ierr /= 0) then - print *, 'Error in FKINGetLinWorkSpace, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetLinWorkSpace, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print '(A)', 'Final Statistics..' print *, ' ' - print '(3(A,i6))' ,'nni = ', nni, ' nli = ', nli, ' ncfl = ',ncfl - print '(3(A,i6))' ,'nfe = ', nfe, ' nfeLS = ', nfeLS, ' njt = ',njvevals - print '(2(A,i6))' ,'npe = ', npe, ' nps = ', nps + print '(3(A,i6))', 'nni = ', nni, ' nli = ', nli, ' ncfl = ', ncfl + print '(3(A,i6))', 'nfe = ', nfe, ' nfeLS = ', nfeLS, ' njt = ', njvevals + print '(2(A,i6))', 'npe = ', npe, ' nps = ', nps print *, ' ' - print '(2(A,i6))' ,'lenrw = ', lenrw, ' leniw = ', leniw - print '(2(A,i6))' ,'lenrwLS = ', lenrwLS, ' leniwLS = ', leniwLS + print '(2(A,i6))', 'lenrw = ', lenrw, ' leniw = ', leniw + print '(2(A,i6))', 'lenrwLS = ', lenrwLS, ' leniwLS = ', leniwLS return diff --git a/examples/kinsol/F2003_serial/kinRoboKin_dns_f2003.f90 b/examples/kinsol/F2003_serial/kinRoboKin_dns_f2003.f90 index 2399a29ea5..509d3df13c 100644 --- a/examples/kinsol/F2003_serial/kinRoboKin_dns_f2003.f90 +++ b/examples/kinsol/F2003_serial/kinRoboKin_dns_f2003.f90 @@ -36,8 +36,8 @@ module prob_mod integer(c_int64_t), parameter :: nvar = 8 integer(c_int64_t), parameter :: neq = 3*nvar - real(c_double), parameter :: ftol = 1.d-5 - real(c_double), parameter :: stol = 1.d-5 + real(c_double), parameter :: ftol = 1.d-5 + real(c_double), parameter :: stol = 1.d-5 contains @@ -50,7 +50,7 @@ module prob_mod ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function func(sunvec_y, sunvec_f, user_data) & - result(ierr) bind(C,name='func') + result(ierr) bind(C, name='func') !======= Inclusions =========== use, intrinsic :: iso_c_binding @@ -62,7 +62,7 @@ integer(c_int) function func(sunvec_y, sunvec_f, user_data) & ! calling variables type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data ! pointers to data in SUNDIALS vectors real(c_double), pointer :: yd(:) @@ -109,12 +109,12 @@ integer(c_int) function func(sunvec_y, sunvec_f, user_data) & u8 = yd(24) ! Nonlinear equations - eq1 = - 0.1238d0*x1 + x7 - 0.001637d0*x2 - 0.9338d0*x4 & + eq1 = -0.1238d0*x1 + x7 - 0.001637d0*x2 - 0.9338d0*x4 & + 0.004731d0*x1*x3 - 0.3578d0*x2*x3 - 0.3571d0 eq2 = 0.2638d0*x1 - x7 - 0.07745d0*x2 - 0.6734d0*x4 & - + 0.2238d0*x1*x3 + 0.7623d0*x2*x3 - 0.6022d0 + + 0.2238d0*x1*x3 + 0.7623d0*x2*x3 - 0.6022d0 eq3 = 0.3578d0*x1 + 0.004731d0*x2 + x6*x8 - eq4 = - 0.7623d0*x1 + 0.2238d0*x2 + 0.3461d0 + eq4 = -0.7623d0*x1 + 0.2238d0*x2 + 0.3461d0 eq5 = x1*x1 + x2*x2 - 1.d0 eq6 = x3*x3 + x4*x4 - 1.d0 eq7 = x5*x5 + x6*x6 - 1.d0 @@ -172,7 +172,6 @@ integer(c_int) function func(sunvec_y, sunvec_f, user_data) & end function func - ! ---------------------------------------------------------------- ! jac: The nonlinear system Jacobian ! @@ -182,12 +181,11 @@ end function func ! -1 = non-recoverable error ! ---------------------------------------------------------------- integer(c_int) function jac(sunvec_y, sunvec_f, sunmat_J, user_data, sunvec_t1, sunvec_t2) & - result(ierr) bind(C,name='jac') + result(ierr) bind(C, name='jac') !======= Inclusions =========== use, intrinsic :: iso_c_binding - use fnvector_serial_mod use fsunmatrix_dense_mod @@ -198,13 +196,13 @@ integer(c_int) function jac(sunvec_y, sunvec_f, sunmat_J, user_data, sunvec_t1, type(N_Vector) :: sunvec_y ! solution N_Vector type(N_Vector) :: sunvec_f ! rhs N_Vector type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix - type(c_ptr), value :: user_data ! user-defined data + type(c_ptr), value :: user_data ! user-defined data type(N_Vector) :: sunvec_t1 ! temporary N_Vectors type(N_Vector) :: sunvec_t2 ! pointers to data in SUNDIALS vector and matrix real(c_double), pointer :: yd(:) - real(c_double), pointer :: J(:,:) + real(c_double), pointer :: J(:, :) ! internal variables real(c_double) :: x1, x2, x3, x4, x5, x6, x7, x8 @@ -230,57 +228,57 @@ integer(c_int) function jac(sunvec_y, sunvec_f, sunmat_J, user_data, sunvec_t1, ! Nonlinear equations ! -0.1238*x1 + x7 - 0.001637*x2 - 0.9338*x4 + 0.004731*x1*x3 - 0.3578*x2*x3 - 0.3571 - J(1,1) = -0.1238d0 + 0.004731d0*x3 - J(1,2) = -0.001637d0 - 0.3578d0*x3 - J(1,3) = 0.004731d0*x1 - 0.3578d0*x2 - J(1,4) = -0.9338d0 - J(1,7) = 1.d0 + J(1, 1) = -0.1238d0 + 0.004731d0*x3 + J(1, 2) = -0.001637d0 - 0.3578d0*x3 + J(1, 3) = 0.004731d0*x1 - 0.3578d0*x2 + J(1, 4) = -0.9338d0 + J(1, 7) = 1.d0 ! 0.2638*x1 - x7 - 0.07745*x2 - 0.6734*x4 + 0.2238*x1*x3 + 0.7623*x2*x3 - 0.6022 - J(2,1) = 0.2638d0 + 0.2238d0*x3 - J(2,2) = -0.07745d0 + 0.7623d0*x3 - J(2,3) = 0.2238d0*x1 + 0.7623d0*x2 - J(2,4) = -0.6734d0 - J(2,7) = -1.d0 + J(2, 1) = 0.2638d0 + 0.2238d0*x3 + J(2, 2) = -0.07745d0 + 0.7623d0*x3 + J(2, 3) = 0.2238d0*x1 + 0.7623d0*x2 + J(2, 4) = -0.6734d0 + J(2, 7) = -1.d0 ! 0.3578*x1 + 0.004731*x2 + x6*x8 - J(3,1) = 0.3578d0 - J(3,2) = 0.004731d0 - J(3,6) = x8 - J(3,8) = x6 + J(3, 1) = 0.3578d0 + J(3, 2) = 0.004731d0 + J(3, 6) = x8 + J(3, 8) = x6 ! -0.7623*x1 + 0.2238*x2 + 0.3461 - J(4,1) = -0.7623d0 - J(4,2) = 0.2238d0 + J(4, 1) = -0.7623d0 + J(4, 2) = 0.2238d0 ! x1*x1 + x2*x2 - 1 - J(5,1) = 2.d0*x1 - J(5,2) = 2.d0*x2 + J(5, 1) = 2.d0*x1 + J(5, 2) = 2.d0*x2 ! x3*x3 + x4*x4 - 1 - J(6,3) = 2.d0*x3 - J(6,4) = 2.d0*x4 + J(6, 3) = 2.d0*x3 + J(6, 4) = 2.d0*x4 ! x5*x5 + x6*x6 - 1 - J(7,5) = 2.d0*x5 - J(7,6) = 2.d0*x6 + J(7, 5) = 2.d0*x5 + J(7, 6) = 2.d0*x6 ! x7*x7 + x8*x8 - 1 - J(8,7) = 2.d0*x7 - J(8,8) = 2.d0*x8 + J(8, 7) = 2.d0*x7 + J(8, 8) = 2.d0*x8 ! -------------------- ! Lower bounds ( l_i = 1 + x_i >= 0) - do i = 1,8 - J(8+i,i) = -1.d0 - J(8+i,8+i) = 1.d0 + do i = 1, 8 + J(8 + i, i) = -1.d0 + J(8 + i, 8 + i) = 1.d0 end do ! -------------------- ! Upper bounds ( u_i = 1 - x_i >= 0) - do i = 1,8 - J(16+i,i) = 1.d0 - J(16+i,16+i) = 1.d0 + do i = 1, 8 + J(16 + i, i) = 1.d0 + J(16 + i, 16 + i) = 1.d0 end do ! Return success @@ -291,7 +289,6 @@ end function jac end module prob_mod - program main !======= Inclusions =========== @@ -312,10 +309,10 @@ program main integer(c_long) :: mset type(c_ptr) :: sunctx - type(N_Vector), pointer :: sunvec_y ! sundials vectors - type(N_Vector), pointer :: sunvec_s - type(N_Vector), pointer :: sunvec_c - type(SUNMatrix), pointer :: sunmat_J ! sundials matrix + type(N_Vector), pointer :: sunvec_y ! sundials vectors + type(N_Vector), pointer :: sunvec_s + type(N_Vector), pointer :: sunvec_c + type(SUNMatrix), pointer :: sunmat_J ! sundials matrix type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver type(c_ptr) :: kmem ! KINSOL memory @@ -340,7 +337,7 @@ program main y(1:nvar) = dsqrt(2.d0)/2.d0 scale = 1.d0 constraints = 0.d0 - constraints(nvar+1:neq) = 1.d0 + constraints(nvar + 1:neq) = 1.d0 ! ------------------------- ! Create the SUNDIALS context used for this simulation @@ -351,20 +348,20 @@ program main sunvec_y => FN_VMake_Serial(neq, y, sunctx) if (.not. associated(sunvec_y)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_s => FN_VMake_Serial(neq, scale, sunctx) if (.not. associated(sunvec_s)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if sunvec_c => FN_VMake_Serial(neq, constraints, sunctx) if (.not. associated(sunvec_c)) then - print *, 'ERROR: sunvec = NULL' - stop 1 + print *, 'ERROR: sunvec = NULL' + stop 1 end if ! ------------------------- @@ -372,14 +369,14 @@ program main kmem = FKINCreate(sunctx) if (.not. c_associated(kmem)) then - print *, 'ERROR: kmem = NULL' - stop 1 + print *, 'ERROR: kmem = NULL' + stop 1 end if ierr = FKINInit(kmem, c_funloc(func), sunvec_y) if (ierr /= 0) then - print *, 'Error in FKINInit, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINInit, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -387,22 +384,22 @@ program main ierr = FKINSetConstraints(kmem, sunvec_c) if (ierr /= 0) then - print *, 'Error in FKINSetConstraints, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetConstraints, ierr = ', ierr, '; halting' + stop 1 end if fnormtol = ftol ierr = FKINSetFuncNormTol(kmem, fnormtol) if (ierr /= 0) then - print *, 'Error in FKINSetFuncNormTol, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetFuncNormTol, ierr = ', ierr, '; halting' + stop 1 end if scsteptol = stol ierr = FKINSetScaledStepTol(kmem, scsteptol) if (ierr /= 0) then - print *, 'Error in FKINSetScaledStepTol, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetScaledStepTol, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -410,8 +407,8 @@ program main sunmat_J => FSUNDenseMatrix(neq, neq, sunctx) if (.not. associated(sunmat_J)) then - print *,'ERROR: sunmat = NULL' - stop 1 + print *, 'ERROR: sunmat = NULL' + stop 1 end if ! ------------------------- @@ -419,8 +416,8 @@ program main sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_J, sunctx) if (.not. associated(sunlinsol_LS)) then - print *,'ERROR: sunlinsol = NULL' - stop 1 + print *, 'ERROR: sunlinsol = NULL' + stop 1 end if ! ------------------------- @@ -428,8 +425,8 @@ program main ierr = FKINSetLinearSolver(kmem, sunlinsol_LS, sunmat_J) if (ierr /= 0) then - print *, 'Error in FKINSetLinearSolver, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetLinearSolver, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -437,8 +434,8 @@ program main ierr = FKINSetJacFn(kmem, c_funloc(jac)) if (ierr /= 0) then - print *, 'Error in FKINSetJacFn, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetJacFn, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -447,8 +444,8 @@ program main mset = 1 ierr = FKINSetMaxSetupCalls(kmem, mset) if (ierr /= 0) then - print *, 'Error in FKINSetMaxSetupCalls, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSetMaxSetupCalls, ierr = ', ierr, '; halting' + stop 1 end if ! ------------------------- @@ -465,15 +462,14 @@ program main ierr = FKINSol(kmem, sunvec_y, KIN_LINESEARCH, sunvec_s, sunvec_s) if (ierr /= 0) then - print *, 'Error in FKINSol, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINSol, ierr = ', ierr, '; halting' + stop 1 end if print *, " " print *, "Computed solution:" call PrintOutput(y) - ! ------------------------- ! Print final statistics and free memory @@ -488,7 +484,6 @@ program main end program main - ! ---------------------------------------------------------------- ! PrintOutput: prints solution at selected points ! ---------------------------------------------------------------- @@ -512,14 +507,13 @@ subroutine PrintOutput(y) print *, " l=x+1 x u=1-x" print *, " ----------------------------------" - do i = 1,NVAR - print '(1x,3(f10.6,3x))', y(i+nvar), y(i), y(i+2*nvar) + do i = 1, NVAR + print '(1x,3(f10.6,3x))', y(i + nvar), y(i), y(i + 2*nvar) end do return end subroutine PrintOutput - ! ---------------------------------------------------------------- ! PrintFinalStats ! @@ -543,33 +537,33 @@ subroutine PrintFinalStats(kmem) ierr = FKINGetNumNonlinSolvIters(kmem, nni) if (ierr /= 0) then - print *, 'Error in FKINGetNumNonlinSolvIters, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumNonlinSolvIters, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumFuncEvals(kmem, nfe) if (ierr /= 0) then - print *, 'Error in FKINGetNumFuncEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumFuncEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumJacEvals(kmem, nje) if (ierr /= 0) then - print *, 'Error in FKINGetNumJacEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumJacEvals, ierr = ', ierr, '; halting' + stop 1 end if ierr = FKINGetNumLinFuncEvals(kmem, nfeD) if (ierr /= 0) then - print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' - stop 1 + print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting' + stop 1 end if print *, ' ' print *, 'Final Statistics.. ' print *, ' ' - print '(2(A,i5))' ,'nni =', nni, ' nfe =', nfe - print '(2(A,i5))' ,'nje =', nje, ' nfeD =', nfeD + print '(2(A,i5))', 'nni =', nni, ' nfe =', nfe + print '(2(A,i5))', 'nje =', nje, ' nfeD =', nfeD return diff --git a/examples/nvector/C_openmp/test_fnvector_openmp_mod.f90 b/examples/nvector/C_openmp/test_fnvector_openmp_mod.f90 index afa1157fef..971f0b2c08 100644 --- a/examples/nvector/C_openmp/test_fnvector_openmp_mod.f90 +++ b/examples/nvector/C_openmp/test_fnvector_openmp_mod.f90 @@ -26,7 +26,7 @@ module test_nvector_openmp integer(kind=myindextype), parameter :: ns = 2 ! number of vector arrays integer(c_int), parameter :: nv = 3 ! length of vector arrays - contains +contains integer function smoke_tests() result(ret) implicit none @@ -50,7 +50,7 @@ integer function smoke_tests() result(ret) xvecs = FN_VCloneVectorArray(nv, x) zvecs = FN_VCloneVectorArray(nv, z) - nvarr = (/ ONE, ONE, ONE /) + nvarr = (/ONE, ONE, ONE/) !===== Test ===== @@ -141,7 +141,6 @@ end function unit_tests end module - integer(C_INT) function check_ans(ans, X, local_length) result(failure) use, intrinsic :: iso_c_binding @@ -163,7 +162,6 @@ integer(C_INT) function check_ans(ans, X, local_length) result(failure) end do end function check_ans - logical function has_data(X) result(failure) use, intrinsic :: iso_c_binding @@ -177,7 +175,6 @@ logical function has_data(X) result(failure) failure = associated(xptr) end function has_data - program main !======== Inclusions ========== use, intrinsic :: iso_c_binding diff --git a/examples/nvector/manyvector/test_fnvector_manyvector_mod.f90 b/examples/nvector/manyvector/test_fnvector_manyvector_mod.f90 index cf12181129..b6b99d480a 100644 --- a/examples/nvector/manyvector/test_fnvector_manyvector_mod.f90 +++ b/examples/nvector/manyvector/test_fnvector_manyvector_mod.f90 @@ -24,10 +24,10 @@ module test_nvector_manyvector implicit none integer(c_int), parameter :: nsubvecs = 2 - integer(c_int), parameter :: nv = 3 ! length of vector arrays - integer(kind=myindextype), parameter :: N1 = 100 ! individual vector length - integer(kind=myindextype), parameter :: N2 = 200 ! individual vector length - integer(kind=myindextype), parameter :: N = N1 + N2 ! overall manyvector length + integer(c_int), parameter :: nv = 3 ! length of vector arrays + integer(kind=myindextype), parameter :: N1 = 100 ! individual vector length + integer(kind=myindextype), parameter :: N2 = 200 ! individual vector length + integer(kind=myindextype), parameter :: N = N1 + N2 ! overall manyvector length contains @@ -46,9 +46,9 @@ integer function smoke_tests() result(ret) !===== Setup ==== subvecs = FN_VNewVectorArray(nsubvecs, sunctx) - tmp => FN_VMake_Serial(N1, x1data, sunctx) + tmp => FN_VMake_Serial(N1, x1data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 0, tmp) - tmp => FN_VMake_Serial(N2, x2data, sunctx) + tmp => FN_VMake_Serial(N2, x2data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 1, tmp) x => FN_VNew_ManyVector(int(nsubvecs, myindextype), subvecs, sunctx) @@ -60,7 +60,7 @@ integer function smoke_tests() result(ret) xvecs = FN_VCloneVectorArray(nv, x) zvecs = FN_VCloneVectorArray(nv, z) - nvarr = (/ ONE, ONE, ONE /) + nvarr = (/ONE, ONE, ONE/) !===== Test ===== @@ -105,10 +105,10 @@ integer function smoke_tests() result(ret) ! test the ManyVector specific operations ival = FN_VGetNumSubvectors_ManyVector(x) - xptr => FN_VGetSubvectorArrayPointer_ManyVector(x, ival-1) - ival = FN_VSetSubvectorArrayPointer_ManyVector(xptr, x, ival-1) + xptr => FN_VGetSubvectorArrayPointer_ManyVector(x, ival - 1) + ival = FN_VSetSubvectorArrayPointer_ManyVector(xptr, x, ival - 1) ival = FN_VGetNumSubvectors_ManyVector(x) - tmp => FN_VGetSubvector_ManyVector(x, ival-1) + tmp => FN_VGetSubvector_ManyVector(x, ival - 1) !==== Cleanup ===== call FN_VDestroyVectorArray(subvecs, nsubvecs) @@ -135,9 +135,9 @@ integer function unit_tests() result(fails) fails = 0 subvecs = FN_VNewVectorArray(nsubvecs, sunctx) - tmp => FN_VMake_Serial(N1, x1data, sunctx) + tmp => FN_VMake_Serial(N1, x1data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 0, tmp) - tmp => FN_VMake_Serial(N2, x2data, sunctx) + tmp => FN_VMake_Serial(N2, x2data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 1, tmp) x => FN_VNew_ManyVector(int(nsubvecs, myindextype), subvecs, sunctx) @@ -156,7 +156,6 @@ end function unit_tests end module - function check_ans(ans, X, local_length) result(failure) use, intrinsic :: iso_c_binding use fnvector_manyvector_mod @@ -181,13 +180,13 @@ function check_ans(ans, X, local_length) result(failure) if (local_length /= (x0len + x1len)) then failure = 1 return - endif + end if do i = 1, x0len if (FNEQ(x0data(i), ans) > 0) then failure = failure + 1 end if - enddo + end do do i = 1, x1len if (FNEQ(x1data(i), ans) > 0) then @@ -196,7 +195,6 @@ function check_ans(ans, X, local_length) result(failure) end do end function check_ans - logical function has_data(X) result(failure) use, intrinsic :: iso_c_binding @@ -208,7 +206,6 @@ logical function has_data(X) result(failure) failure = .true. end function has_data - program main !======== Inclusions ========== use, intrinsic :: iso_c_binding diff --git a/examples/nvector/mpimanyvector/test_fnvector_mpimanyvector_mod.f90 b/examples/nvector/mpimanyvector/test_fnvector_mpimanyvector_mod.f90 index 1b25a3f139..94d18d00ec 100644 --- a/examples/nvector/mpimanyvector/test_fnvector_mpimanyvector_mod.f90 +++ b/examples/nvector/mpimanyvector/test_fnvector_mpimanyvector_mod.f90 @@ -18,7 +18,6 @@ module test_nvector_mpimanyvector use, intrinsic :: iso_c_binding - use fnvector_mpimanyvector_mod use fnvector_serial_mod use test_utilities @@ -50,9 +49,9 @@ integer function smoke_tests() result(ret) !===== Setup ==== subvecs = FN_VNewVectorArray(nsubvecs, sunctx) - tmp => FN_VMake_Serial(N1, x1data, sunctx) + tmp => FN_VMake_Serial(N1, x1data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 0, tmp) - tmp => FN_VMake_Serial(N2, x2data, sunctx) + tmp => FN_VMake_Serial(N2, x2data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 1, tmp) x => FN_VMake_MPIManyVector(comm, int(nsubvecs, myindextype), subvecs, sunctx) @@ -64,7 +63,7 @@ integer function smoke_tests() result(ret) xvecs = FN_VCloneVectorArray(nv, x) zvecs = FN_VCloneVectorArray(nv, z) - nvarr = (/ ONE, ONE, ONE /) + nvarr = (/ONE, ONE, ONE/) !===== Test ===== @@ -109,10 +108,10 @@ integer function smoke_tests() result(ret) ! test the MPIManyVector specific operations ival = FN_VGetNumSubvectors_MPIManyVector(x) - xptr => FN_VGetSubvectorArrayPointer_MPIManyVector(x, ival-1) - ival = FN_VSetSubvectorArrayPointer_MPIManyVector(xptr, x, ival-1) + xptr => FN_VGetSubvectorArrayPointer_MPIManyVector(x, ival - 1) + ival = FN_VSetSubvectorArrayPointer_MPIManyVector(xptr, x, ival - 1) ival = FN_VGetNumSubvectors_MPIManyVector(x) - tmp => FN_VGetSubvector_MPIManyVector(x, ival-1) + tmp => FN_VGetSubvector_MPIManyVector(x, ival - 1) !==== Cleanup ===== tmp => FN_VGetVecAtIndexVectorArray(subvecs, 0) @@ -146,12 +145,12 @@ integer function unit_tests() result(fails) if (fails /= 0) then print *, ' FAILURE - MPI_COMM_RANK returned nonzero' stop 1 - endif + end if subvecs = FN_VNewVectorArray(nsubvecs, sunctx) - tmp => FN_VMake_Serial(N1, x1data, sunctx) + tmp => FN_VMake_Serial(N1, x1data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 0, tmp) - tmp => FN_VMake_Serial(N2, x2data, sunctx) + tmp => FN_VMake_Serial(N2, x2data, sunctx) call FN_VSetVecAtIndexVectorArray(subvecs, 1, tmp) x => FN_VMake_MPIManyVector(comm, int(nsubvecs, myindextype), subvecs, sunctx) @@ -173,11 +172,10 @@ end function unit_tests end module - integer(C_INT) function check_ans(ans, X, local_length) result(failure) use, intrinsic :: iso_c_binding use fnvector_mpimanyvector_mod - use test_utilities + use test_utilities implicit none real(C_DOUBLE) :: ans @@ -198,13 +196,13 @@ integer(C_INT) function check_ans(ans, X, local_length) result(failure) if (local_length /= (x0len + x1len)) then failure = 1 return - endif + end if do i = 1, x0len if (FNEQ(x0data(i), ans) > 0) then failure = failure + 1 end if - enddo + end do do i = 1, x1len if (FNEQ(x1data(i), ans) > 0) then @@ -213,7 +211,6 @@ integer(C_INT) function check_ans(ans, X, local_length) result(failure) end do end function check_ans - logical function has_data(X) result(failure) use, intrinsic :: iso_c_binding @@ -225,7 +222,6 @@ logical function has_data(X) result(failure) failure = .true. end function has_data - program main !======== Inclusions ========== use, intrinsic :: iso_c_binding @@ -241,13 +237,13 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_INIT returned nonzero' stop 1 - endif + end if call MPI_Comm_rank(comm, myid, fails) if (fails /= 0) then print *, 'FAILURE: MPI_COMM_RANK returned nonzero, proc', myid stop 1 - endif + end if !============== Introduction ============= if (myid == 0) print *, 'MPIManyVector N_Vector Fortran 2003 interface test' @@ -258,7 +254,7 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_COMM_SIZE returned nonzero, proc', myid stop 1 - endif + end if fails = smoke_tests() if (fails /= 0) then @@ -272,14 +268,14 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_BARRIER returned nonzero, proc', myid stop 1 - endif + end if fails = unit_tests() if (fails /= 0) then print *, 'FAILURE: n unit tests failed, proc', myid stop 1 else - if (myid == 0) print *,' SUCCESS - all unit tests passed' + if (myid == 0) print *, ' SUCCESS - all unit tests passed' end if call Test_Finalize() @@ -288,5 +284,5 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_FINALIZE returned nonzero, proc ', myid stop 1 - endif + end if end program main diff --git a/examples/nvector/mpiplusx/test_fnvector_mpiplusx_mod.f90 b/examples/nvector/mpiplusx/test_fnvector_mpiplusx_mod.f90 index 180944377d..ac2f3f75f1 100644 --- a/examples/nvector/mpiplusx/test_fnvector_mpiplusx_mod.f90 +++ b/examples/nvector/mpiplusx/test_fnvector_mpiplusx_mod.f90 @@ -39,7 +39,7 @@ integer function smoke_tests() result(ret) type(N_Vector), pointer :: x, local ! N_Vectors !===== Setup ==== - local => FN_VMake_Serial(N, x1data, sunctx) + local => FN_VMake_Serial(N, x1data, sunctx) x => FN_VMake_MPIPlusX(comm, local, sunctx) call FN_VConst(ONE, x) @@ -47,10 +47,10 @@ integer function smoke_tests() result(ret) !===== Test ===== ! test the MPIPlusX specific operations - xptr => FN_VGetArrayPointer_MPIPlusX(x) + xptr => FN_VGetArrayPointer_MPIPlusX(x) local => FN_VGetLocalVector_MPIPlusX(x) - ival = FN_VGetLocalLength_MPIPlusX(x) - ival = FN_VGetVectorID_MPIPlusX(x) + ival = FN_VGetLocalLength_MPIPlusX(x) + ival = FN_VGetVectorID_MPIPlusX(x) !==== Cleanup ===== call FN_VDestroy(local) @@ -75,9 +75,9 @@ integer function unit_tests() result(fails) if (fails /= 0) then print *, ' FAILURE - MPI_COMM_RANK returned nonzero' stop 1 - endif + end if - local => FN_VMake_Serial(N, x1data, sunctx) + local => FN_VMake_Serial(N, x1data, sunctx) x => FN_VMake_MPIPlusX(comm, local, sunctx) call FN_VConst(ONE, x) @@ -95,7 +95,6 @@ end function unit_tests end module - integer(C_INT) function check_ans(ans, X, local_length) result(failure) use, intrinsic :: iso_c_binding use fnvector_mpiplusx_mod @@ -118,17 +117,16 @@ integer(C_INT) function check_ans(ans, X, local_length) result(failure) if (local_length /= x0len) then failure = 1 return - endif + end if do i = 1, x0len if (FNEQ(x0data(i), ans) > 0) then failure = failure + 1 end if - enddo + end do end function check_ans - logical function has_data(X) result(failure) use, intrinsic :: iso_c_binding @@ -140,7 +138,6 @@ logical function has_data(X) result(failure) failure = .true. end function has_data - program main !======== Inclusions ========== use, intrinsic :: iso_c_binding @@ -156,13 +153,13 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_INIT returned nonzero' stop 1 - endif + end if call MPI_Comm_rank(comm, myid, fails) if (fails /= 0) then print *, 'FAILURE: MPI_COMM_RANK returned nonzero, proc', myid stop 1 - endif + end if !============== Introduction ============= if (myid == 0) print *, 'MPIPlusX N_Vector Fortran 2003 interface test' @@ -173,7 +170,7 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_COMM_SIZE returned nonzero, proc', myid stop 1 - endif + end if fails = smoke_tests() if (fails /= 0) then @@ -187,14 +184,14 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_BARRIER returned nonzero, proc', myid stop 1 - endif + end if fails = unit_tests() if (fails /= 0) then print *, 'FAILURE: n unit tests failed, proc', myid stop 1 else - if (myid == 0) print *,' SUCCESS - all unit tests passed' + if (myid == 0) print *, ' SUCCESS - all unit tests passed' end if call Test_Finalize() @@ -203,5 +200,5 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_FINALIZE returned nonzero, proc ', myid stop 1 - endif + end if end program main diff --git a/examples/nvector/parallel/test_fnvector_parallel_mod.f90 b/examples/nvector/parallel/test_fnvector_parallel_mod.f90 index 8ca51a39ba..e473e0fa61 100644 --- a/examples/nvector/parallel/test_fnvector_parallel_mod.f90 +++ b/examples/nvector/parallel/test_fnvector_parallel_mod.f90 @@ -30,7 +30,7 @@ module test_nvector_parallel integer(c_int), target :: comm = MPI_COMM_WORLD ! default MPI communicator integer(kind=myindextype) :: global_length ! vector global_length integer(c_int) :: nprocs ! number of MPI processes - contains +contains integer function smoke_tests() result(ret) implicit none @@ -54,7 +54,7 @@ integer function smoke_tests() result(ret) xvecs = FN_VCloneVectorArray(nv, x) zvecs = FN_VCloneVectorArray(nv, z) - nvarr = (/ ONE, ONE, ONE /) + nvarr = (/ONE, ONE, ONE/) !===== Test ===== @@ -136,7 +136,7 @@ integer function unit_tests() result(fails) if (fails /= 0) then print *, ' FAILURE - MPI_COMM_RANK returned nonzero' stop 1 - endif + end if x => FN_VMake_Parallel(comm, local_length, global_length, xdata, sunctx) call FN_VConst(ONE, x) @@ -153,7 +153,6 @@ end function unit_tests end module - integer(C_INT) function check_ans(ans, X, local_length) result(failure) use, intrinsic :: iso_c_binding @@ -168,14 +167,13 @@ integer(C_INT) function check_ans(ans, X, local_length) result(failure) failure = 0 Xdata => FN_VGetArrayPointer(X) - do i = 1, local_length + do i = 1, local_length if (FNEQ(Xdata(i), ans) > 0) then failure = failure + 1 end if end do end function check_ans - logical function has_data(X) result(failure) use, intrinsic :: iso_c_binding @@ -189,7 +187,6 @@ logical function has_data(X) result(failure) failure = associated(xptr) end function has_data - program main !======== Inclusions ========== use, intrinsic :: iso_c_binding @@ -205,13 +202,13 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_INIT returned nonzero' stop 1 - endif + end if call MPI_Comm_rank(comm, myid, fails) if (fails /= 0) then print *, 'FAILURE: MPI_COMM_RANK returned nonzero, proc', myid stop 1 - endif + end if !============== Introduction ============= if (myid == 0) print *, 'Parallel N_Vector Fortran 2003 interface test' @@ -222,7 +219,7 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_COMM_SIZE returned nonzero, proc', myid stop 1 - endif + end if global_length = nprocs*local_length fails = smoke_tests() @@ -237,14 +234,14 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_BARRIER returned nonzero, proc', myid stop 1 - endif + end if fails = unit_tests() if (fails /= 0) then print *, 'FAILURE: n unit tests failed, proc', myid stop 1 else - if (myid == 0) print *,' SUCCESS - all unit tests passed' + if (myid == 0) print *, ' SUCCESS - all unit tests passed' end if call Test_Finalize() @@ -253,6 +250,6 @@ program main if (fails /= 0) then print *, 'FAILURE: MPI_FINALIZE returned nonzero, proc ', myid stop 1 - endif + end if end program main diff --git a/examples/nvector/pthreads/test_fnvector_pthreads_mod.f90 b/examples/nvector/pthreads/test_fnvector_pthreads_mod.f90 index 96db87411a..c8223103d2 100644 --- a/examples/nvector/pthreads/test_fnvector_pthreads_mod.f90 +++ b/examples/nvector/pthreads/test_fnvector_pthreads_mod.f90 @@ -25,7 +25,7 @@ module test_nvector_pthreads integer(kind=myindextype), parameter :: ns = 2 ! number of vector arrays integer(c_int), parameter :: nv = 3 ! length of vector arrays - contains +contains integer function smoke_tests() result(ret) implicit none @@ -49,7 +49,7 @@ integer function smoke_tests() result(ret) xvecs = FN_VCloneVectorArray(nv, x) zvecs = FN_VCloneVectorArray(nv, z) - nvarr = (/ ONE, ONE, ONE /) + nvarr = (/ONE, ONE, ONE/) !===== Test ===== @@ -140,7 +140,6 @@ end function unit_tests end module - integer(C_INT) function check_ans(ans, X, local_length) result(failure) use, intrinsic :: iso_c_binding @@ -162,7 +161,6 @@ integer(C_INT) function check_ans(ans, X, local_length) result(failure) end do end function check_ans - logical function has_data(X) result(failure) use, intrinsic :: iso_c_binding @@ -176,7 +174,6 @@ logical function has_data(X) result(failure) failure = associated(xptr) end function has_data - program main !======== Inclusions ========== use, intrinsic :: iso_c_binding diff --git a/examples/nvector/serial/test_fnvector_serial_mod.f90 b/examples/nvector/serial/test_fnvector_serial_mod.f90 index 8c725b6207..4f0daf3921 100644 --- a/examples/nvector/serial/test_fnvector_serial_mod.f90 +++ b/examples/nvector/serial/test_fnvector_serial_mod.f90 @@ -49,7 +49,7 @@ integer function smoke_tests() result(ret) xvecs = FN_VCloneVectorArray(nv, x) zvecs = FN_VCloneVectorArray(nv, z) - nvarr = (/ ONE, ONE, ONE /) + nvarr = (/ONE, ONE, ONE/) !===== Test ===== @@ -161,7 +161,6 @@ function check_ans(ans, X, local_length) result(failure) end do end function check_ans - logical function has_data(X) result(failure) use, intrinsic :: iso_c_binding use test_utilities diff --git a/examples/nvector/test_nvector.f90 b/examples/nvector/test_nvector.f90 index b97f65b3ca..855d0d6dd1 100644 --- a/examples/nvector/test_nvector.f90 +++ b/examples/nvector/test_nvector.f90 @@ -30,152 +30,148 @@ module test_fnvector contains - -integer(C_INT) function Test_FN_VMake(X, local_length, myid) & + integer(C_INT) function Test_FN_VMake(X, local_length, myid) & result(failure) - implicit none - - type(N_Vector) :: X - integer(kind=myindextype) :: local_length - integer(C_INT) :: myid + implicit none - if (.not. has_data(X)) then - print *, '(I4)', '>>> FAILED test -- FN_VMake, Proc ', myid - print *, ' vector data is not associated' - failure = 1 - return - end if + type(N_Vector) :: X + integer(kind=myindextype) :: local_length + integer(C_INT) :: myid - if (myid == 0) then - print *, 'PASSED test -- FN_VMake' - end if + if (.not. has_data(X)) then + print *, '(I4)', '>>> FAILED test -- FN_VMake, Proc ', myid + print *, ' vector data is not associated' + failure = 1 + return + end if - failure = 0 -end function Test_FN_VMake + if (myid == 0) then + print *, 'PASSED test -- FN_VMake' + end if + failure = 0 + end function Test_FN_VMake !! ---------------------------------------------------------------------- !! NOTE: This routine depends on FN_VConst to check vector data. !! ---------------------------------------------------------------------- -integer(C_INT) function Test_FN_VGetArrayPointer(W, local_length, myid) & + integer(C_INT) function Test_FN_VGetArrayPointer(W, local_length, myid) & result(failure) - implicit none - - type(N_Vector) :: W - integer(kind=myindextype) :: local_length - integer(C_INT) :: myid - - ! check vector data - if (.not. has_data(W)) then - print *, '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid - print *, ' Vector data == NULL \n\n' - failure = 1 - return; - end if - - call FN_VConst(NEG_HALF, W) - failure = check_ans(NEG_HALF, W, local_length) - - if (failure > 0) then - print *, '(I2)', '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid - print *, ' Failed FN_VConst check \n\n' - failure = 1 - return - end if - - if (myid == 0) then - print *, 'PASSED test -- FN_VConst' - print *, 'PASSED test -- FN_VGetArrayPointer' - end if - - failure = 0 -end function Test_FN_VGetArrayPointer - - -integer(C_INT) function Test_FN_VLinearCombination(X, local_length, myid) & + implicit none + + type(N_Vector) :: W + integer(kind=myindextype) :: local_length + integer(C_INT) :: myid + + ! check vector data + if (.not. has_data(W)) then + print *, '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid + print *, ' Vector data == NULL \n\n' + failure = 1 + return; + end if + + call FN_VConst(NEG_HALF, W) + failure = check_ans(NEG_HALF, W, local_length) + + if (failure > 0) then + print *, '(I2)', '>>> FAILED test -- FN_VGetArrayPointer, Proc ', myid + print *, ' Failed FN_VConst check \n\n' + failure = 1 + return + end if + + if (myid == 0) then + print *, 'PASSED test -- FN_VConst' + print *, 'PASSED test -- FN_VGetArrayPointer' + end if + + failure = 0 + end function Test_FN_VGetArrayPointer + + integer(C_INT) function Test_FN_VLinearCombination(X, local_length, myid) & result(failure) - type(N_Vector) :: X - integer(kind=myindextype) :: local_length - integer(C_INT) :: myid, ierr - type(N_Vector), pointer :: Y1, Y2, Y3 - type(c_ptr), target :: V(3) - type(c_ptr) :: Vptr - real(C_DOUBLE) :: c(3) - - failure = 0 - - ! create vectors for testing - Y1 => FN_VClone(X) - Y2 => FN_VClone(X) - Y3 => FN_VClone(X) - - ! set vectors in vector array - V(1) = c_loc(Y1) - V(2) = c_loc(Y2) - V(3) = c_loc(Y3) - Vptr = c_loc(V) - - ! initialize c values - c = ZERO - - ! - ! Case 1a: V[0] = a V[0], FN_VScale - ! - - ! fill vector data - call FN_VConst(TWO, Y1) - - ! set scaling factors - c = HALF - - ierr = FN_VLinearCombination(1, c, Vptr, Y1) - - ! Y1 should be vector of +1 - if (ierr == 0) then - failure = check_ans(ONE, Y1, local_length) - else - failure = 1 - end if - - if (failure > 0) then - print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 1a, Proc ', myid - else if (myid == 0) then - print *, 'PASSED test -- FN_VLinearCombination Case 1a' - end if - - ! - ! Case 3a: V[0] = V[0] + b V[1] + c V[2] - ! - - call FN_VConst(TWO, Y1) - call FN_VConst(NEG_TWO, Y2) - call FN_VConst(NEG_ONE, Y3) - - c(1) = ONE - c(2) = HALF - c(3) = NEG_TWO - - ierr = FN_VLinearCombination(3, c, Vptr, Y1) - - ! Y1 should be vector of +3 - if (ierr == 0) then - failure = check_ans(TWO+ONE, Y1, local_length) - else - failure = 1 - end if - - if (failure > 0) then - print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 3a, Proc ', myid - else if (myid == 0) then - print *, 'PASSED test -- FN_VLinearCombination Case 3a' - end if - - ! Free vectors - call FN_VDestroy(Y1); - call FN_VDestroy(Y2); - call FN_VDestroy(Y3); - -end function Test_FN_VLinearCombination + type(N_Vector) :: X + integer(kind=myindextype) :: local_length + integer(C_INT) :: myid, ierr + type(N_Vector), pointer :: Y1, Y2, Y3 + type(c_ptr), target :: V(3) + type(c_ptr) :: Vptr + real(C_DOUBLE) :: c(3) + + failure = 0 + + ! create vectors for testing + Y1 => FN_VClone(X) + Y2 => FN_VClone(X) + Y3 => FN_VClone(X) + + ! set vectors in vector array + V(1) = c_loc(Y1) + V(2) = c_loc(Y2) + V(3) = c_loc(Y3) + Vptr = c_loc(V) + + ! initialize c values + c = ZERO + + ! + ! Case 1a: V[0] = a V[0], FN_VScale + ! + + ! fill vector data + call FN_VConst(TWO, Y1) + + ! set scaling factors + c = HALF + + ierr = FN_VLinearCombination(1, c, Vptr, Y1) + + ! Y1 should be vector of +1 + if (ierr == 0) then + failure = check_ans(ONE, Y1, local_length) + else + failure = 1 + end if + + if (failure > 0) then + print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 1a, Proc ', myid + else if (myid == 0) then + print *, 'PASSED test -- FN_VLinearCombination Case 1a' + end if + + ! + ! Case 3a: V[0] = V[0] + b V[1] + c V[2] + ! + + call FN_VConst(TWO, Y1) + call FN_VConst(NEG_TWO, Y2) + call FN_VConst(NEG_ONE, Y3) + + c(1) = ONE + c(2) = HALF + c(3) = NEG_TWO + + ierr = FN_VLinearCombination(3, c, Vptr, Y1) + + ! Y1 should be vector of +3 + if (ierr == 0) then + failure = check_ans(TWO + ONE, Y1, local_length) + else + failure = 1 + end if + + if (failure > 0) then + print *, '(I4)', '>>> FAILED test -- FN_VLinearCombination Case 3a, Proc ', myid + else if (myid == 0) then + print *, 'PASSED test -- FN_VLinearCombination Case 3a' + end if + + ! Free vectors + call FN_VDestroy(Y1); + call FN_VDestroy(Y2); + call FN_VDestroy(Y3); + end function Test_FN_VLinearCombination end module diff --git a/examples/sunlinsol/band/test_fsunlinsol_band_mod.f90 b/examples/sunlinsol/band/test_fsunlinsol_band_mod.f90 index 8e6e755762..0f238725e7 100644 --- a/examples/sunlinsol/band/test_fsunlinsol_band_mod.f90 +++ b/examples/sunlinsol/band/test_fsunlinsol_band_mod.f90 @@ -26,7 +26,7 @@ module test_fsunlinsol_band contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding use fnvector_serial_mod use fsunmatrix_band_mod @@ -37,12 +37,12 @@ integer(C_INT) function unit_tests() result(fails) type(SUNLinearSolver), pointer :: LS ! test linear solver type(SUNMatrix), pointer :: A ! test matrices - type(N_Vector), pointer :: x, y, b ! test vectors - real(C_DOUBLE), pointer :: xdata(:), Adata(:) ! data arrays - real(C_DOUBLE) :: tmpr ! temporary real value + type(N_Vector), pointer :: x, y, b ! test vectors + real(c_double), pointer :: xdata(:), Adata(:) ! data arrays + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j, k integer(kind=myindextype) :: smu, kstart, kend, offset - integer(C_INT) :: tmp + integer(c_int) :: tmp fails = 0 smu = 0 @@ -54,25 +54,25 @@ integer(C_INT) function unit_tests() result(fails) ! fill A matrix with uniform random data in [0, 1/N) Adata => FSUNBandMatrix_Data(A) - do j=1, N - offset = (j-1)*(smu+ml+1) + smu + 1 ! offset to diagonal - kstart = merge(-mu, -(j-1), j > mu) ! above diagonal - kend = merge(N-j , ml, j > N - ml) ! below diagonal - do k=kstart, kend + do j = 1, N + offset = (j - 1)*(smu + ml + 1) + smu + 1 ! offset to diagonal + kstart = merge(-mu, -(j - 1), j > mu) ! above diagonal + kend = merge(N - j, ml, j > N - ml) ! below diagonal + do k = kstart, kend call random_number(tmpr) - Adata(offset+k) = tmpr / N + Adata(offset + k) = tmpr/N end do end do ! fill x vector with uniform random data in [1, 2) xdata => FN_VGetArrayPointer(x) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + tmpr end do ! scale/shift matrix to ensure diagonal dominance - fails = FSUNMatScaleAddI(ONE/(mu+ml+1), A) + fails = FSUNMatScaleAddI(ONE/(mu + ml + 1), A) if (fails /= 0) then print *, 'FAIL: FSUNMatScaleAddI failure' call FSUNMatDestroy(A) @@ -116,17 +116,15 @@ end function unit_tests end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_utilities implicit none - - type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr + real(c_double) :: tol, maxerr integer(kind=myindextype) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -149,9 +147,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(xdata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(xdata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", FIVE*tol, ")" end if @@ -164,7 +162,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'Band SUNLinearSolver Fortran 2003 interface test' @@ -176,7 +174,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/dense/test_fsunlinsol_dense_mod.f90 b/examples/sunlinsol/dense/test_fsunlinsol_dense_mod.f90 index 34da2d20a3..728a746bd3 100644 --- a/examples/sunlinsol/dense/test_fsunlinsol_dense_mod.f90 +++ b/examples/sunlinsol/dense/test_fsunlinsol_dense_mod.f90 @@ -20,13 +20,11 @@ module test_fsunlinsol_dense use test_utilities implicit none - - integer(kind=myindextype), private, parameter :: N = 100 contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding use fnvector_serial_mod use fsunmatrix_dense_mod @@ -36,13 +34,13 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A, I ! test matrices - type(N_Vector), pointer :: x, b ! test vectors - real(C_DOUBLE), pointer :: colj(:), colIj(:) ! matrix column data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A, I ! test matrices + type(N_Vector), pointer :: x, b ! test vectors + real(c_double), pointer :: colj(:), colIj(:) ! matrix column data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j, k - integer(C_INT) :: tmp + integer(c_int) :: tmp fails = 0 @@ -52,34 +50,34 @@ integer(C_INT) function unit_tests() result(fails) b => FN_VNew_Serial(N, sunctx) ! fill A matrix with uniform random data in [0, 1/N) - do j=1, N - colj => FSUNDenseMatrix_Column(A, j-1) - do k=1, N + do j = 1, N + colj => FSUNDenseMatrix_Column(A, j - 1) + do k = 1, N call random_number(tmpr) - colj(k) = tmpr / N + colj(k) = tmpr/N end do end do ! create anti-identity matrix j = N - do k=1, N - colj => FSUNDenseMatrix_Column(I, j-1) + do k = 1, N + colj => FSUNDenseMatrix_Column(I, j - 1) colj(k) = ONE - j = j-1 + j = j - 1 end do ! add anti-identity to ensure the solver needs to do row-swapping - do k=1, N - do j=1, N - colj => FSUNDenseMatrix_Column(A, j-1) - colIj => FSUNDenseMatrix_Column(I, j-1) + do k = 1, N + do j = 1, N + colj => FSUNDenseMatrix_Column(A, j - 1) + colIj => FSUNDenseMatrix_Column(I, j - 1) colj(k) = colj(k) + colIj(k) end do end do ! fill x vector with uniform random data in [0, 1) xdata => FN_VGetArrayPointer(x) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = tmpr end do @@ -117,17 +115,15 @@ end function unit_tests end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_utilities implicit none - - type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr + real(c_double) :: tol, maxerr integer(kind=myindextype) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -150,9 +146,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(ydata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(ydata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", tol, ")" end if @@ -165,7 +161,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'Dense SUNLinearSolver Fortran 2003 interface test' @@ -177,7 +173,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/klu/test_fsunlinsol_klu_mod.f90 b/examples/sunlinsol/klu/test_fsunlinsol_klu_mod.f90 index c46d15a3b3..a5392d0e6e 100644 --- a/examples/sunlinsol/klu/test_fsunlinsol_klu_mod.f90 +++ b/examples/sunlinsol/klu/test_fsunlinsol_klu_mod.f90 @@ -24,11 +24,9 @@ module test_fsunlinsol_klu contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - - use fnvector_serial_mod use fsunmatrix_dense_mod use fsunmatrix_sparse_mod @@ -38,13 +36,13 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A, D ! test matrices - type(N_Vector), pointer :: x, b ! test vectors - real(C_DOUBLE), pointer :: colj(:) ! matrix column data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A, D ! test matrices + type(N_Vector), pointer :: x, b ! test vectors + real(c_double), pointer :: colj(:) ! matrix column data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j, k, i - integer(C_INT) :: tmp + integer(c_int) :: tmp fails = 0 @@ -53,14 +51,14 @@ integer(C_INT) function unit_tests() result(fails) b => FN_VNew_Serial(N, sunctx) ! fill A matrix with uniform random data in [0, 1/N) - do k=1, 5*N + do k = 1, 5*N call random_number(tmpr) - j = max(1, floor(tmpr * N)) + j = max(1, floor(tmpr*N)) call random_number(tmpr) - i = max(1, floor(tmpr * N)) - colj => FSUNDenseMatrix_Column(D, j-1) + i = max(1, floor(tmpr*N)) + colj => FSUNDenseMatrix_Column(D, j - 1) call random_number(tmpr) - colj(i) = tmpr / N + colj(i) = tmpr/N end do ! add identity to matrix @@ -74,7 +72,7 @@ integer(C_INT) function unit_tests() result(fails) ! fill x vector with uniform random data in [0, 1) xdata => FN_VGetArrayPointer(x) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = tmpr end do @@ -114,16 +112,16 @@ end function unit_tests end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_utilities implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr - integer(C_LONG) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double) :: tol, maxerr + integer(c_long) :: i, xlen, ylen + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -146,9 +144,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", tol, ")" end if @@ -161,7 +159,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'KLU SUNLinearSolver Fortran 2003 interface test' @@ -173,7 +171,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/lapackdense/test_fsunlinsol_lapackdense_mod.f90 b/examples/sunlinsol/lapackdense/test_fsunlinsol_lapackdense_mod.f90 index 387a126399..0088ca8418 100644 --- a/examples/sunlinsol/lapackdense/test_fsunlinsol_lapackdense_mod.f90 +++ b/examples/sunlinsol/lapackdense/test_fsunlinsol_lapackdense_mod.f90 @@ -20,17 +20,13 @@ module test_fsunlinsol_lapackdense use test_utilities implicit none - - integer(kind=myindextype), private, parameter :: N = 100 contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - - use fnvector_serial_mod use fsunmatrix_dense_mod use fsunlinsol_lapackdense_mod @@ -39,13 +35,13 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A, I ! test matrices - type(N_Vector), pointer :: x, b ! test vectors - real(C_DOUBLE), pointer :: colj(:), colIj(:) ! matrix column data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A, I ! test matrices + type(N_Vector), pointer :: x, b ! test vectors + real(c_double), pointer :: colj(:), colIj(:) ! matrix column data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j, k - integer(C_INT) :: tmp + integer(c_int) :: tmp fails = 0 @@ -55,34 +51,34 @@ integer(C_INT) function unit_tests() result(fails) b => FN_VNew_Serial(N, sunctx) ! fill A matrix with uniform random data in [0, 1/N) - do j=1, N - colj => FSUNDenseMatrix_Column(A, j-1) - do k=1, N + do j = 1, N + colj => FSUNDenseMatrix_Column(A, j - 1) + do k = 1, N call random_number(tmpr) - colj(k) = tmpr / N + colj(k) = tmpr/N end do end do ! create anti-identity matrix j = N - do k=1, N - colj => FSUNDenseMatrix_Column(I, j-1) + do k = 1, N + colj => FSUNDenseMatrix_Column(I, j - 1) colj(k) = ONE - j = j-1 + j = j - 1 end do ! add anti-identity to ensure the solver needs to do row-swapping - do k=1, N - do j=1, N - colj => FSUNDenseMatrix_Column(A, j-1) - colIj => FSUNDenseMatrix_Column(I, j-1) + do k = 1, N + do j = 1, N + colj => FSUNDenseMatrix_Column(A, j - 1) + colIj => FSUNDenseMatrix_Column(I, j - 1) colj(k) = colj(k) + colIj(k) end do end do ! fill x vector with uniform random data in [0, 1) xdata => FN_VGetArrayPointer(x) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = tmpr end do @@ -120,15 +116,15 @@ end function unit_tests end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_utilities implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr - integer(C_LONG) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double) :: tol, maxerr + integer(c_long) :: i, xlen, ylen + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -151,9 +147,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(ydata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(ydata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", tol, ")" end if @@ -166,7 +162,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'LAPACK-Dense SUNLinearSolver Fortran 2003 interface test' @@ -178,7 +174,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/pcg/serial/test_fsunlinsol_pcg_mod_serial.f90 b/examples/sunlinsol/pcg/serial/test_fsunlinsol_pcg_mod_serial.f90 index f1c22e2ad9..b5bad44d77 100644 --- a/examples/sunlinsol/pcg/serial/test_fsunlinsol_pcg_mod_serial.f90 +++ b/examples/sunlinsol/pcg/serial/test_fsunlinsol_pcg_mod_serial.f90 @@ -25,12 +25,10 @@ module test_fsunlinsol_pcg_serial use test_utilities implicit none - - integer(kind=myindextype), private, parameter :: N = 100 - integer(C_INT), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) - integer(C_INT), private, parameter :: maxl = 500 ! maxium Krylov subspace dimension (> 0) - real(C_DOUBLE), private, parameter :: tol = 1e-13 ! solver tolerance + integer(c_int), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) + integer(c_int), private, parameter :: maxl = 500 ! maxium Krylov subspace dimension (> 0) + real(c_double), private, parameter :: tol = 1e-13 ! solver tolerance type, private :: UserData integer(kind=myindextype) :: N @@ -39,11 +37,9 @@ module test_fsunlinsol_pcg_serial contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - - use fnvector_serial_mod use fsunlinsol_pcg_mod use test_sunlinsol @@ -51,33 +47,33 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A ! dummy SUNMatrix (set to null) - type(N_Vector), pointer :: x, xhat, b ! test vectors - type(N_Vector), pointer :: s2 ! dummy scaling vector (set to null) - type(UserData), pointer :: probdata ! problem data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A ! dummy SUNMatrix (set to null) + type(N_Vector), pointer :: x, xhat, b ! test vectors + type(N_Vector), pointer :: s2 ! dummy scaling vector (set to null) + type(UserData), pointer :: probdata ! problem data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j - integer(C_INT) :: tmp + integer(c_int) :: tmp ! setup fails = 0 - A => null() + A => null() s2 => null() - x => FN_VNew_Serial(N, sunctx) + x => FN_VNew_Serial(N, sunctx) xhat => FN_VNew_Serial(N, sunctx) - b => FN_VNew_Serial(N, sunctx) + b => FN_VNew_Serial(N, sunctx) - allocate(probdata) + allocate (probdata) probdata%N = N probdata%d => FN_VNew_Serial(N, sunctx) probdata%s => FN_VNew_Serial(N, sunctx) ! fill xhat vector with uniform random data in [1, 2) xdata => FN_VGetArrayPointer(xhat) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + tmpr end do @@ -90,14 +86,14 @@ integer(C_INT) function unit_tests() result(fails) ! run initialization tests fails = fails + Test_FSUNLinSolGetType(LS, SUNLINEARSOLVER_ITERATIVE, 0) - fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata),& + fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata), & c_funloc(ATimes), 0) - fails = fails + Test_FSUNLinSolSetPreconditioner(LS,& - c_loc(probdata),& - c_funloc(PSetup),& - c_funloc(PSolve),& + fails = fails + Test_FSUNLinSolSetPreconditioner(LS, & + c_loc(probdata), & + c_funloc(PSetup), & + c_funloc(PSolve), & 0) - fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s,& + fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s, & s2, 0) fails = fails + Test_FSUNLinSolInitialize(LS, 0) fails = fails + Test_FSUNLinSolSpace(LS, 0) @@ -125,14 +121,13 @@ integer(C_INT) function unit_tests() result(fails) end if ! Run tests with this setup - fails = fails + FSUNLinSol_PCGSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_PCGSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_PCG module, problem 1' else @@ -156,14 +151,13 @@ integer(C_INT) function unit_tests() result(fails) end if ! Run tests with this setup - fails = fails + FSUNLinSol_PCGSetPrecType(LS, pretype); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_PCGSetPrecType(LS, pretype); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_PCG module, problem 2' else @@ -175,7 +169,7 @@ integer(C_INT) function unit_tests() result(fails) ! set scaling vectors xdata => FN_VGetArrayPointer(probdata%s) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + 1000.0d0*tmpr end do @@ -191,14 +185,13 @@ integer(C_INT) function unit_tests() result(fails) end if ! Run tests with this setup - fails = fails + FSUNLinSol_PCGSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_PCGSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_PCG module, problem 3' else @@ -213,22 +206,22 @@ integer(C_INT) function unit_tests() result(fails) call FN_VDestroy(b) call FN_VDestroy(probdata%d) call FN_VDestroy(probdata%s) - deallocate(probdata) + deallocate (probdata) end function unit_tests - integer(C_INT) function ATimes(udata, vvec, zvec) result(ret) bind(C) + integer(c_int) function ATimes(udata, vvec, zvec) result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: vvec, zvec type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: v(:), z(:), s(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: v(:), z(:), s(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) @@ -241,37 +234,37 @@ integer(C_INT) function ATimes(udata, vvec, zvec) result(ret) bind(C) z(1) = (FIVE*v(1)/s(1) - v(2)/s(2))/s(1) ! iterate through interior of local domain, performing product - do i = 2, N-1 - z(i) = (-v(i-1)/s(i-1) + FIVE*v(i)/s(i) - v(i+1)/s(i+1))/s(i) + do i = 2, N - 1 + z(i) = (-v(i - 1)/s(i - 1) + FIVE*v(i)/s(i) - v(i + 1)/s(i + 1))/s(i) end do ! perform product at the right domain boundary (note: v is zero at the boundary) - z(N) = (-v(N-1)/s(N-1) + FIVE*v(N)/s(N))/s(N) + z(N) = (-v(N - 1)/s(N - 1) + FIVE*v(N)/s(N))/s(N) ret = 0 end function ATimes - integer(C_INT) function PSetup(udata) result(ret) bind(C) + integer(c_int) function PSetup(udata) result(ret) bind(C) use, intrinsic :: iso_c_binding - type(C_PTR), value :: udata + type(c_ptr), value :: udata ret = 0 end function PSetup - integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & - result(ret) bind(C) + integer(c_int) function PSolve(udata, rvec, zvec, tol, lr) & + result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: rvec, zvec - real(C_DOUBLE) :: tol - integer(C_INT) :: lr + real(c_double) :: tol + integer(c_int) :: lr type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: r(:), z(:), d(:), s(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: r(:), z(:), d(:), s(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) @@ -281,8 +274,8 @@ integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & s => FN_VGetArrayPointer(probdata%s) N = probdata%N - do i=1, N - z(i) = s(i) * s(i) * r(i) / d(i) + do i = 1, N + z(i) = s(i)*s(i)*r(i)/d(i) end do ret = 0 @@ -290,16 +283,16 @@ end function PSolve end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_fsunlinsol_pcg_serial use test_utilities implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr - integer(C_LONG) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double) :: tol, maxerr + integer(c_long) :: i, xlen, ylen + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -322,9 +315,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(xdata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(xdata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", FIVE*tol, ")" end if @@ -337,7 +330,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'PCG SUNLinearSolver Fortran 2003 interface test' @@ -350,7 +343,7 @@ program main print *, 'FAILURE: ', fails, ' unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/spbcgs/serial/test_fsunlinsol_spbcgs_mod_serial.f90 b/examples/sunlinsol/spbcgs/serial/test_fsunlinsol_spbcgs_mod_serial.f90 index 12941ec00c..7d5d2dfae6 100644 --- a/examples/sunlinsol/spbcgs/serial/test_fsunlinsol_spbcgs_mod_serial.f90 +++ b/examples/sunlinsol/spbcgs/serial/test_fsunlinsol_spbcgs_mod_serial.f90 @@ -25,12 +25,10 @@ module test_fsunlinsol_spbcgs_serial use test_utilities implicit none - - integer(kind=myindextype), private, parameter :: N = 100 - integer(C_INT), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) - integer(C_INT), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) - real(C_DOUBLE), private, parameter :: tol = 1e-13 ! solver tolerance + integer(c_int), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) + integer(c_int), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) + real(c_double), private, parameter :: tol = 1e-13 ! solver tolerance type, private :: UserData integer(kind=myindextype) :: N @@ -39,11 +37,9 @@ module test_fsunlinsol_spbcgs_serial contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - - use fnvector_serial_mod use fsunlinsol_spbcgs_mod use test_sunlinsol @@ -51,32 +47,32 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A ! dummy SUNMatrix - type(N_Vector), pointer :: x, xhat, b ! test vectors - type(UserData), pointer :: probdata ! problem data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A ! dummy SUNMatrix + type(N_Vector), pointer :: x, xhat, b ! test vectors + type(UserData), pointer :: probdata ! problem data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j - integer(C_INT) :: tmp + integer(c_int) :: tmp ! setup fails = 0 A => null() - x => FN_VNew_Serial(N, sunctx) + x => FN_VNew_Serial(N, sunctx) xhat => FN_VNew_Serial(N, sunctx) - b => FN_VNew_Serial(N, sunctx) + b => FN_VNew_Serial(N, sunctx) - allocate(probdata) + allocate (probdata) probdata%N = N - probdata%d => FN_VNew_Serial(N, sunctx) + probdata%d => FN_VNew_Serial(N, sunctx) probdata%s1 => FN_VNew_Serial(N, sunctx) probdata%s2 => FN_VNew_Serial(N, sunctx) ! fill xhat vector with uniform random data in [1, 2) xdata => FN_VGetArrayPointer(xhat) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + tmpr end do @@ -89,14 +85,14 @@ integer(C_INT) function unit_tests() result(fails) ! run initialization tests fails = fails + Test_FSUNLinSolGetType(LS, SUNLINEARSOLVER_ITERATIVE, 0) - fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata),& + fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata), & c_funloc(ATimes), 0) - fails = fails + Test_FSUNLinSolSetPreconditioner(LS,& - c_loc(probdata),& - c_funloc(PSetup),& - c_funloc(PSolve),& + fails = fails + Test_FSUNLinSolSetPreconditioner(LS, & + c_loc(probdata), & + c_funloc(PSetup), & + c_funloc(PSolve), & 0) - fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1,& + fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1, & probdata%s2, 0) fails = fails + Test_FSUNLinSolInitialize(LS, 0) fails = fails + Test_FSUNLinSolSpace(LS, 0) @@ -121,14 +117,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPBCGSSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPBCGSSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPBCGS module, problem 1' else @@ -149,14 +144,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPBCGSSetPrecType(LS, pretype); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPBCGSSetPrecType(LS, pretype); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPBCGS module, problem 2' else @@ -168,7 +162,7 @@ integer(C_INT) function unit_tests() result(fails) ! set scaling vectors xdata => FN_VGetArrayPointer(probdata%s1) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + 1000.0d0*tmpr end do @@ -181,14 +175,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPBCGSSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPBCGSSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPBCGS module, problem 3' else @@ -204,66 +197,66 @@ integer(C_INT) function unit_tests() result(fails) call FN_VDestroy(probdata%d) call FN_VDestroy(probdata%s1) call FN_VDestroy(probdata%s2) - deallocate(probdata) + deallocate (probdata) end function unit_tests - integer(C_INT) function ATimes(udata, vvec, zvec) result(ret) bind(C) + integer(c_int) function ATimes(udata, vvec, zvec) result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: vvec, zvec type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: v(:), z(:), s1(:), s2(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: v(:), z(:), s1(:), s2(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) - v => FN_VGetArrayPointer(vvec) - z => FN_VGetArrayPointer(zvec) + v => FN_VGetArrayPointer(vvec) + z => FN_VGetArrayPointer(zvec) s1 => FN_VGetArrayPointer(probdata%s1) s2 => FN_VGetArrayPointer(probdata%s2) - N = probdata%N + N = probdata%N ! perform product at the left domain boundary (note: v is zero at the boundary) z(1) = (FIVE*v(1)*s2(1) - v(2)*s2(2))/s1(1) ! iterate through interior of local domain, performing product - do i = 2, N-1 - z(i) = (-v(i-1)*s2(i-1) + FIVE*v(i)*s2(i) - v(i+1)*s2(i+1))/s1(i) + do i = 2, N - 1 + z(i) = (-v(i - 1)*s2(i - 1) + FIVE*v(i)*s2(i) - v(i + 1)*s2(i + 1))/s1(i) end do ! perform product at the right domain boundary (note: v is zero at the boundary) - z(N) = (-v(N-1)*s2(N-1) + FIVE*v(N)*s2(N))/s1(N) + z(N) = (-v(N - 1)*s2(N - 1) + FIVE*v(N)*s2(N))/s1(N) ret = 0 end function ATimes - integer(C_INT) function PSetup(udata) result(ret) bind(C) + integer(c_int) function PSetup(udata) result(ret) bind(C) use, intrinsic :: iso_c_binding - type(C_PTR), value :: udata + type(c_ptr), value :: udata ret = 0 end function PSetup - integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & - result(ret) bind(C) + integer(c_int) function PSolve(udata, rvec, zvec, tol, lr) & + result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: rvec, zvec - real(C_DOUBLE) :: tol - integer(C_INT) :: lr + real(c_double) :: tol + integer(c_int) :: lr type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: r(:), z(:), d(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: r(:), z(:), d(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) @@ -272,8 +265,8 @@ integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & d => FN_VGetArrayPointer(probdata%d) N = probdata%N - do i=1, N - z(i) = r(i) / d(i) + do i = 1, N + z(i) = r(i)/d(i) end do ret = 0 @@ -281,16 +274,16 @@ end function PSolve end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_fsunlinsol_spbcgs_serial use test_utilities implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr - integer(C_LONG) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double) :: tol, maxerr + integer(c_long) :: i, xlen, ylen + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -313,9 +306,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(xdata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(xdata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", FIVE*tol, ")" end if @@ -328,7 +321,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'SPBCGS SUNLinearSolver Fortran 2003 interface test' @@ -341,7 +334,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/spfgmr/serial/test_fsunlinsol_spfgmr_mod_serial.f90 b/examples/sunlinsol/spfgmr/serial/test_fsunlinsol_spfgmr_mod_serial.f90 index aa5066aed7..0a14009745 100644 --- a/examples/sunlinsol/spfgmr/serial/test_fsunlinsol_spfgmr_mod_serial.f90 +++ b/examples/sunlinsol/spfgmr/serial/test_fsunlinsol_spfgmr_mod_serial.f90 @@ -24,13 +24,11 @@ module test_fsunlinsol_spfgmr_serial use test_utilities implicit none - - integer(kind=myindextype), private, parameter :: N = 100 - integer(C_INT), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) - integer(C_INT), private, parameter :: gstype = 1 ! Gram-Schmidt orthoognalization type (1 or 2) - integer(C_INT), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) - real(C_DOUBLE), private, parameter :: tol = 1e-13 ! solver tolerance + integer(c_int), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) + integer(c_int), private, parameter :: gstype = 1 ! Gram-Schmidt orthoognalization type (1 or 2) + integer(c_int), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) + real(c_double), private, parameter :: tol = 1e-13 ! solver tolerance type, private :: UserData integer(kind=myindextype) :: N @@ -39,7 +37,7 @@ module test_fsunlinsol_spfgmr_serial contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding use fnvector_serial_mod use fsunlinsol_spfgmr_mod @@ -48,32 +46,32 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A ! dummy SUNMatrix - type(N_Vector), pointer :: x, xhat, b ! test vectors - type(UserData), pointer :: probdata ! problem data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A ! dummy SUNMatrix + type(N_Vector), pointer :: x, xhat, b ! test vectors + type(UserData), pointer :: probdata ! problem data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j - integer(C_INT) :: tmp + integer(c_int) :: tmp ! setup fails = 0 A => null() - x => FN_VNew_Serial(N, sunctx) + x => FN_VNew_Serial(N, sunctx) xhat => FN_VNew_Serial(N, sunctx) - b => FN_VNew_Serial(N, sunctx) + b => FN_VNew_Serial(N, sunctx) - allocate(probdata) - probdata%N = N - probdata%d => FN_VNew_Serial(N, sunctx) + allocate (probdata) + probdata%N = N + probdata%d => FN_VNew_Serial(N, sunctx) probdata%s1 => FN_VNew_Serial(N, sunctx) probdata%s2 => FN_VNew_Serial(N, sunctx) ! fill xhat vector with uniform random data in [1, 2) xdata => FN_VGetArrayPointer(xhat) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + tmpr end do @@ -86,14 +84,14 @@ integer(C_INT) function unit_tests() result(fails) ! run initialization tests fails = fails + Test_FSUNLinSolGetType(LS, SUNLINEARSOLVER_ITERATIVE, 0) - fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata),& + fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata), & c_funloc(ATimes), 0) - fails = fails + Test_FSUNLinSolSetPreconditioner(LS,& - c_loc(probdata),& - c_funloc(PSetup),& - c_funloc(PSolve),& + fails = fails + Test_FSUNLinSolSetPreconditioner(LS, & + c_loc(probdata), & + c_funloc(PSetup), & + c_funloc(PSolve), & 0) - fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1,& + fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1, & probdata%s2, 0) fails = fails + Test_FSUNLinSolInitialize(LS, 0) fails = fails + Test_FSUNLinSolSpace(LS, 0) @@ -119,14 +117,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPFGMR module, problem 1' else @@ -147,14 +144,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, pretype); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, pretype); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPFGMR module, problem 2' else @@ -166,7 +162,7 @@ integer(C_INT) function unit_tests() result(fails) ! set scaling vectors xdata => FN_VGetArrayPointer(probdata%s1) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + 1000.0d0*tmpr end do @@ -179,14 +175,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPFGMR module, problem 3' else @@ -202,66 +197,66 @@ integer(C_INT) function unit_tests() result(fails) call FN_VDestroy(probdata%d) call FN_VDestroy(probdata%s1) call FN_VDestroy(probdata%s2) - deallocate(probdata) + deallocate (probdata) end function unit_tests - integer(C_INT) function ATimes(udata, vvec, zvec) result(ret) bind(C) + integer(c_int) function ATimes(udata, vvec, zvec) result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: vvec, zvec type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: v(:), z(:), s1(:), s2(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: v(:), z(:), s1(:), s2(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) - v => FN_VGetArrayPointer(vvec) - z => FN_VGetArrayPointer(zvec) + v => FN_VGetArrayPointer(vvec) + z => FN_VGetArrayPointer(zvec) s1 => FN_VGetArrayPointer(probdata%s1) s2 => FN_VGetArrayPointer(probdata%s2) - N = probdata%N + N = probdata%N ! perform product at the left domain boundary (note: v is zero at the boundary) z(1) = (FIVE*v(1)*s2(1) - v(2)*s2(2))/s1(1) ! iterate through interior of local domain, performing product - do i = 2, N-1 - z(i) = (-v(i-1)*s2(i-1) + FIVE*v(i)*s2(i) - v(i+1)*s2(i+1))/s1(i) + do i = 2, N - 1 + z(i) = (-v(i - 1)*s2(i - 1) + FIVE*v(i)*s2(i) - v(i + 1)*s2(i + 1))/s1(i) end do ! perform product at the right domain boundary (note: v is zero at the boundary) - z(N) = (-v(N-1)*s2(N-1) + FIVE*v(N)*s2(N))/s1(N) + z(N) = (-v(N - 1)*s2(N - 1) + FIVE*v(N)*s2(N))/s1(N) ret = 0 end function ATimes - integer(C_INT) function PSetup(udata) result(ret) bind(C) + integer(c_int) function PSetup(udata) result(ret) bind(C) use, intrinsic :: iso_c_binding - type(C_PTR), value :: udata + type(c_ptr), value :: udata ret = 0 end function PSetup - integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & - result(ret) bind(C) + integer(c_int) function PSolve(udata, rvec, zvec, tol, lr) & + result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: rvec, zvec - real(C_DOUBLE) :: tol - integer(C_INT) :: lr + real(c_double) :: tol + integer(c_int) :: lr type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: r(:), z(:), d(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: r(:), z(:), d(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) @@ -270,8 +265,8 @@ integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & d => FN_VGetArrayPointer(probdata%d) N = probdata%N - do i=1, N - z(i) = r(i) / d(i) + do i = 1, N + z(i) = r(i)/d(i) end do ret = 0 @@ -279,16 +274,16 @@ end function PSolve end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_fsunlinsol_spfgmr_serial use test_utilities implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr - integer(C_LONG) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double) :: tol, maxerr + integer(c_long) :: i, xlen, ylen + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -311,9 +306,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(xdata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(xdata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", FIVE*tol, ")" end if @@ -326,7 +321,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'SPFGMR SUNLinearSolver Fortran 2003 interface test' @@ -339,7 +334,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/spgmr/serial/test_fsunlinsol_spgmr_mod_serial.f90 b/examples/sunlinsol/spgmr/serial/test_fsunlinsol_spgmr_mod_serial.f90 index 9f72112a41..0f9dec6568 100644 --- a/examples/sunlinsol/spgmr/serial/test_fsunlinsol_spgmr_mod_serial.f90 +++ b/examples/sunlinsol/spgmr/serial/test_fsunlinsol_spgmr_mod_serial.f90 @@ -24,13 +24,11 @@ module test_fsunlinsol_spgmr_serial use test_utilities implicit none - - integer(kind=myindextype), private, parameter :: N = 100 - integer(C_INT), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) - integer(C_INT), private, parameter :: gstype = 1 ! Gram-Schmidt orthoognalization type (1 or 2) - integer(C_INT), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) - real(C_DOUBLE), private, parameter :: tol = 1e-13 ! solver tolerance + integer(c_int), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) + integer(c_int), private, parameter :: gstype = 1 ! Gram-Schmidt orthoognalization type (1 or 2) + integer(c_int), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) + real(c_double), private, parameter :: tol = 1e-13 ! solver tolerance type, private :: UserData integer(kind=myindextype) :: N @@ -39,7 +37,7 @@ module test_fsunlinsol_spgmr_serial contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding use fnvector_serial_mod use fsunlinsol_spgmr_mod @@ -48,32 +46,32 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A ! dummy SUNMatrix - type(N_Vector), pointer :: x, xhat, b ! test vectors - type(UserData), pointer :: probdata ! problem data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A ! dummy SUNMatrix + type(N_Vector), pointer :: x, xhat, b ! test vectors + type(UserData), pointer :: probdata ! problem data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j - integer(C_INT) :: tmp + integer(c_int) :: tmp ! setup fails = 0 A => null() - x => FN_VNew_Serial(N, sunctx) + x => FN_VNew_Serial(N, sunctx) xhat => FN_VNew_Serial(N, sunctx) - b => FN_VNew_Serial(N, sunctx) + b => FN_VNew_Serial(N, sunctx) - allocate(probdata) - probdata%N = N - probdata%d => FN_VNew_Serial(N, sunctx) + allocate (probdata) + probdata%N = N + probdata%d => FN_VNew_Serial(N, sunctx) probdata%s1 => FN_VNew_Serial(N, sunctx) probdata%s2 => FN_VNew_Serial(N, sunctx) ! fill xhat vector with uniform random data in [1, 2) xdata => FN_VGetArrayPointer(xhat) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + tmpr end do @@ -86,14 +84,14 @@ integer(C_INT) function unit_tests() result(fails) ! run initialization tests fails = fails + Test_FSUNLinSolGetType(LS, SUNLINEARSOLVER_ITERATIVE, 0) - fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata),& + fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata), & c_funloc(ATimes), 0) - fails = fails + Test_FSUNLinSolSetPreconditioner(LS,& - c_loc(probdata),& - c_funloc(PSetup),& - c_funloc(PSolve),& + fails = fails + Test_FSUNLinSolSetPreconditioner(LS, & + c_loc(probdata), & + c_funloc(PSetup), & + c_funloc(PSolve), & 0) - fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1,& + fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1, & probdata%s2, 0) fails = fails + Test_FSUNLinSolInitialize(LS, 0) fails = fails + Test_FSUNLinSolSpace(LS, 0) @@ -119,14 +117,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPGMRSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPGMRSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPGMR module, problem 1' else @@ -147,14 +144,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPGMRSetPrecType(LS, pretype); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPGMRSetPrecType(LS, pretype); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPGMR module, problem 2' else @@ -166,7 +162,7 @@ integer(C_INT) function unit_tests() result(fails) ! set scaling vectors xdata => FN_VGetArrayPointer(probdata%s1) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + 1000.0d0*tmpr end do @@ -179,14 +175,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPGMRSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPGMRSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPGMR module, problem 3' else @@ -202,65 +197,65 @@ integer(C_INT) function unit_tests() result(fails) call FN_VDestroy(probdata%d) call FN_VDestroy(probdata%s1) call FN_VDestroy(probdata%s2) - deallocate(probdata) + deallocate (probdata) end function unit_tests - integer(C_INT) function ATimes(udata, vvec, zvec) result(ret) bind(C) + integer(c_int) function ATimes(udata, vvec, zvec) result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: vvec, zvec type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: v(:), z(:), s1(:), s2(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: v(:), z(:), s1(:), s2(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) - v => FN_VGetArrayPointer(vvec) - z => FN_VGetArrayPointer(zvec) + v => FN_VGetArrayPointer(vvec) + z => FN_VGetArrayPointer(zvec) s1 => FN_VGetArrayPointer(probdata%s1) s2 => FN_VGetArrayPointer(probdata%s2) - N = probdata%N + N = probdata%N ! perform product at the left domain boundary (note: v is zero at the boundary) z(1) = (FIVE*v(1)*s2(1) - v(2)*s2(2))/s1(1) ! iterate through interior of local domain, performing product - do i = 2, N-1 - z(i) = (-v(i-1)*s2(i-1) + FIVE*v(i)*s2(i) - v(i+1)*s2(i+1))/s1(i) + do i = 2, N - 1 + z(i) = (-v(i - 1)*s2(i - 1) + FIVE*v(i)*s2(i) - v(i + 1)*s2(i + 1))/s1(i) end do ! perform product at the right domain boundary (note: v is zero at the boundary) - z(N) = (-v(N-1)*s2(N-1) + FIVE*v(N)*s2(N))/s1(N) + z(N) = (-v(N - 1)*s2(N - 1) + FIVE*v(N)*s2(N))/s1(N) ret = 0 end function ATimes - integer(C_INT) function PSetup(udata) result(ret) bind(C) + integer(c_int) function PSetup(udata) result(ret) bind(C) use, intrinsic :: iso_c_binding - type(C_PTR), value :: udata + type(c_ptr), value :: udata ret = 0 end function PSetup - integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & - result(ret) bind(C) + integer(c_int) function PSolve(udata, rvec, zvec, tol, lr) & + result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: rvec, zvec - real(C_DOUBLE) :: tol - integer(C_INT) :: lr + real(c_double) :: tol + integer(c_int) :: lr type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: r(:), z(:), d(:) + real(c_double), pointer :: r(:), z(:), d(:) integer(kind=myindextype) :: i, N call c_f_pointer(udata, probdata) @@ -270,8 +265,8 @@ integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & d => FN_VGetArrayPointer(probdata%d) N = probdata%N - do i=1, N - z(i) = r(i) / d(i) + do i = 1, N + z(i) = r(i)/d(i) end do ret = 0 @@ -279,16 +274,16 @@ end function PSolve end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_fsunlinsol_spgmr_serial use test_utilities implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr + real(c_double) :: tol, maxerr integer(kind=myindextype) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -311,9 +306,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(xdata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(xdata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", FIVE*tol, ")" end if @@ -326,7 +321,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'SPGMR SUNLinearSolver Fortran 2003 interface test' @@ -339,7 +334,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/sptfqmr/serial/test_fsunlinsol_sptfqmr_mod_serial.f90 b/examples/sunlinsol/sptfqmr/serial/test_fsunlinsol_sptfqmr_mod_serial.f90 index ea6d19df35..85c89199f2 100644 --- a/examples/sunlinsol/sptfqmr/serial/test_fsunlinsol_sptfqmr_mod_serial.f90 +++ b/examples/sunlinsol/sptfqmr/serial/test_fsunlinsol_sptfqmr_mod_serial.f90 @@ -25,12 +25,10 @@ module test_fsunlinsol_sptfqmr_serial use test_utilities implicit none - - integer(kind=myindextype), private, parameter :: N = 100 - integer(C_INT), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) - integer(C_INT), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) - real(C_DOUBLE), private, parameter :: tol = 1e-13 ! solver tolerance + integer(c_int), private, parameter :: pretype = 1 ! Preconditioning type (1 or 2) + integer(c_int), private, parameter :: maxl = 100 ! maxium Krylov subspace dimension (> 0) + real(c_double), private, parameter :: tol = 1e-13 ! solver tolerance type, private :: UserData integer(kind=myindextype) :: N @@ -39,11 +37,9 @@ module test_fsunlinsol_sptfqmr_serial contains - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - - use fnvector_serial_mod use fsunlinsol_sptfqmr_mod use test_sunlinsol @@ -51,32 +47,32 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNLinearSolver), pointer :: LS ! test linear solver - type(SUNMatrix), pointer :: A ! dummy SUNMatrix - type(N_Vector), pointer :: x, xhat, b ! test vectors - type(UserData), pointer :: probdata ! problem data - real(C_DOUBLE), pointer :: xdata(:) ! x vector data - real(C_DOUBLE) :: tmpr ! temporary real value + type(SUNMatrix), pointer :: A ! dummy SUNMatrix + type(N_Vector), pointer :: x, xhat, b ! test vectors + type(UserData), pointer :: probdata ! problem data + real(c_double), pointer :: xdata(:) ! x vector data + real(c_double) :: tmpr ! temporary real value integer(kind=myindextype) :: j - integer(C_INT) :: tmp + integer(c_int) :: tmp ! setup fails = 0 A => null() - x => FN_VNew_Serial(N, sunctx) + x => FN_VNew_Serial(N, sunctx) xhat => FN_VNew_Serial(N, sunctx) - b => FN_VNew_Serial(N, sunctx) + b => FN_VNew_Serial(N, sunctx) - allocate(probdata) - probdata%N = N - probdata%d => FN_VNew_Serial(N, sunctx) + allocate (probdata) + probdata%N = N + probdata%d => FN_VNew_Serial(N, sunctx) probdata%s1 => FN_VNew_Serial(N, sunctx) probdata%s2 => FN_VNew_Serial(N, sunctx) ! fill xhat vector with uniform random data in [1, 2) xdata => FN_VGetArrayPointer(xhat) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + tmpr end do @@ -89,14 +85,14 @@ integer(C_INT) function unit_tests() result(fails) ! run initialization tests fails = fails + Test_FSUNLinSolGetType(LS, SUNLINEARSOLVER_ITERATIVE, 0) - fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata),& + fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata), & c_funloc(ATimes), 0) - fails = fails + Test_FSUNLinSolSetPreconditioner(LS,& - c_loc(probdata),& - c_funloc(PSetup),& - c_funloc(PSolve),& + fails = fails + Test_FSUNLinSolSetPreconditioner(LS, & + c_loc(probdata), & + c_funloc(PSetup), & + c_funloc(PSolve), & 0) - fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1,& + fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1, & probdata%s2, 0) fails = fails + Test_FSUNLinSolInitialize(LS, 0) fails = fails + Test_FSUNLinSolSpace(LS, 0) @@ -121,14 +117,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPTFQMRSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPTFQMRSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPTFQMR module, problem 1' else @@ -149,14 +144,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPTFQMRSetPrecType(LS, pretype); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPTFQMRSetPrecType(LS, pretype); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPTFQMR module, problem 2' else @@ -168,7 +162,7 @@ integer(C_INT) function unit_tests() result(fails) ! set scaling vectors xdata => FN_VGetArrayPointer(probdata%s1) - do j=1, N + do j = 1, N call random_number(tmpr) xdata(j) = ONE + 1000.0d0*tmpr end do @@ -181,14 +175,13 @@ integer(C_INT) function unit_tests() result(fails) fails = fails + ATimes(c_loc(probdata), x, b) ! Run tests with this setup - fails = fails + FSUNLinSol_SPTFQMRSetPrecType(LS, SUN_PREC_NONE); - fails = fails + Test_FSUNLinSolSetup(LS, A, 0); - fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); - fails = fails + Test_FSUNLinSolLastFlag(LS, 0); - fails = fails + Test_FSUNLinSolNumIters(LS, 0); - fails = fails + Test_FSUNLinSolResNorm(LS, 0); - fails = fails + Test_FSUNLinSolResid(LS, 0); - + fails = fails + FSUNLinSol_SPTFQMRSetPrecType(LS, SUN_PREC_NONE); + fails = fails + Test_FSUNLinSolSetup(LS, A, 0); + fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0); + fails = fails + Test_FSUNLinSolLastFlag(LS, 0); + fails = fails + Test_FSUNLinSolNumIters(LS, 0); + fails = fails + Test_FSUNLinSolResNorm(LS, 0); + fails = fails + Test_FSUNLinSolResid(LS, 0); if (fails /= 0) then print *, 'FAIL: FSUNLinSol_SPTFQMR module, problem 3' else @@ -204,66 +197,66 @@ integer(C_INT) function unit_tests() result(fails) call FN_VDestroy(probdata%d) call FN_VDestroy(probdata%s1) call FN_VDestroy(probdata%s2) - deallocate(probdata) + deallocate (probdata) end function unit_tests - integer(C_INT) function ATimes(udata, vvec, zvec) result(ret) bind(C) + integer(c_int) function ATimes(udata, vvec, zvec) result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: vvec, zvec type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: v(:), z(:), s1(:), s2(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: v(:), z(:), s1(:), s2(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) - v => FN_VGetArrayPointer(vvec) - z => FN_VGetArrayPointer(zvec) + v => FN_VGetArrayPointer(vvec) + z => FN_VGetArrayPointer(zvec) s1 => FN_VGetArrayPointer(probdata%s1) s2 => FN_VGetArrayPointer(probdata%s2) - N = probdata%N + N = probdata%N ! perform product at the left domain boundary (note: v is zero at the boundary) z(1) = (FIVE*v(1)*s2(1) - v(2)*s2(2))/s1(1) ! iterate through interior of local domain, performing product - do i = 2, N-1 - z(i) = (-v(i-1)*s2(i-1) + FIVE*v(i)*s2(i) - v(i+1)*s2(i+1))/s1(i) + do i = 2, N - 1 + z(i) = (-v(i - 1)*s2(i - 1) + FIVE*v(i)*s2(i) - v(i + 1)*s2(i + 1))/s1(i) end do ! perform product at the right domain boundary (note: v is zero at the boundary) - z(N) = (-v(N-1)*s2(N-1) + FIVE*v(N)*s2(N))/s1(N) + z(N) = (-v(N - 1)*s2(N - 1) + FIVE*v(N)*s2(N))/s1(N) ret = 0 end function ATimes - integer(C_INT) function PSetup(udata) result(ret) bind(C) + integer(c_int) function PSetup(udata) result(ret) bind(C) use, intrinsic :: iso_c_binding - type(C_PTR), value :: udata + type(c_ptr), value :: udata ret = 0 end function PSetup - integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & - result(ret) bind(C) + integer(c_int) function PSolve(udata, rvec, zvec, tol, lr) & + result(ret) bind(C) use, intrinsic :: iso_c_binding use test_utilities implicit none - type(C_PTR), value :: udata + type(c_ptr), value :: udata type(N_Vector) :: rvec, zvec - real(C_DOUBLE) :: tol - integer(C_INT) :: lr + real(c_double) :: tol + integer(c_int) :: lr type(UserData), pointer :: probdata - real(C_DOUBLE), pointer :: r(:), z(:), d(:) - integer(C_LONG) :: i, N + real(c_double), pointer :: r(:), z(:), d(:) + integer(c_long) :: i, N call c_f_pointer(udata, probdata) @@ -272,8 +265,8 @@ integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) & d => FN_VGetArrayPointer(probdata%d) N = probdata%N - do i=1, N - z(i) = r(i) / d(i) + do i = 1, N + z(i) = r(i)/d(i) end do ret = 0 @@ -281,16 +274,16 @@ end function PSolve end module -integer(C_INT) function check_vector(X, Y, tol) result(failure) +integer(c_int) function check_vector(X, Y, tol) result(failure) use, intrinsic :: iso_c_binding use test_fsunlinsol_sptfqmr_serial use test_utilities implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol, maxerr - integer(C_LONG) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double) :: tol, maxerr + integer(c_long) :: i, xlen, ylen + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -313,9 +306,9 @@ integer(C_INT) function check_vector(X, Y, tol) result(failure) if (failure > 0) then maxerr = ZERO do i = 1, xlen - maxerr = max(abs(xdata(i)-ydata(i))/abs(xdata(i)), maxerr) + maxerr = max(abs(xdata(i) - ydata(i))/abs(xdata(i)), maxerr) end do - write(*,'(A,E14.7,A,E14.7,A)') & + write (*, '(A,E14.7,A,E14.7,A)') & "FAIL: check_vector failure: maxerr = ", maxerr, " (tol = ", FIVE*tol, ")" end if @@ -328,7 +321,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'SPTFQMR SUNLinearSolver Fortran 2003 interface test' @@ -341,7 +334,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunlinsol/test_sunlinsol.f90 b/examples/sunlinsol/test_sunlinsol.f90 index ffdb50250c..584d4162ae 100644 --- a/examples/sunlinsol/test_sunlinsol.f90 +++ b/examples/sunlinsol/test_sunlinsol.f90 @@ -26,37 +26,36 @@ module test_sunlinsol implicit none ! check_vector routine is provided by implementation specific tests - integer(C_INT), external :: check_vector + integer(c_int), external :: check_vector contains - integer(C_INT) function Test_FSUNLinSolGetType(S, mysunid, myid) result(failure) + integer(c_int) function Test_FSUNLinSolGetType(S, mysunid, myid) result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver), pointer :: S integer(SUNLinearSolver_Type) :: mysunid, sunid - integer(C_INT) :: myid + integer(c_int) :: myid failure = 0 sunid = FSUNLinSolGetType(S) if (sunid /= mysunid) then failure = 1 - write(*,*) ">>> FAILED test -- FSUNLinSolGetType, Proc", myid + write (*, *) ">>> FAILED test -- FSUNLinSolGetType, Proc", myid else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolGetType" + write (*, *) " PASSED test -- FSUNLinSolGetType" end if end function Test_FSUNLinSolGetType - - integer(C_INT) function Test_FSUNLinSolLastFlag(S, myid) result(failure) + integer(c_int) function Test_FSUNLinSolLastFlag(S, myid) result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver), pointer :: S - integer(C_INT) :: myid - integer(C_LONG) :: lastflag + integer(c_int) :: myid + integer(c_long) :: lastflag failure = 0 @@ -64,40 +63,38 @@ integer(C_INT) function Test_FSUNLinSolLastFlag(S, myid) result(failure) ! which will cause a seg-fault lastflag = FSUNLinSolLastFlag(S) if (myid == 0) then - write(*,'(A,I0,A)') " PASSED test -- FSUNLinSolLastFlag (", lastflag, ")" + write (*, '(A,I0,A)') " PASSED test -- FSUNLinSolLastFlag (", lastflag, ")" end if end function Test_FSUNLinSolLastFlag - - integer(C_INT) function Test_FSUNLinSolSpace(S, myid) result(failure) + integer(c_int) function Test_FSUNLinSolSpace(S, myid) result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver), pointer :: S - integer(C_INT) :: myid - integer(C_LONG) :: lenrw(1), leniw(1) + integer(c_int) :: myid + integer(c_long) :: lenrw(1), leniw(1) failure = 0 ! call FSUNLinSolSpace (failure based on output flag) failure = FSUNLinSolSpace(S, lenrw, leniw) if (failure /= 0) then - write(*,*) ">>> FAILED test -- FSUNLinSolSpace, Proc ", myid + write (*, *) ">>> FAILED test -- FSUNLinSolSpace, Proc ", myid else if (myid == 0) then - write(*,'(A,I0,A,I0)') " PASSED test -- FSUNLinSolSpace, lenrw = ", & - lenrw, " leniw = ", leniw + write (*, '(A,I0,A,I0)') " PASSED test -- FSUNLinSolSpace, lenrw = ", & + lenrw, " leniw = ", leniw end if end function Test_FSUNLinSolSpace - - integer(C_INT) function Test_FSUNLinSolNumIters(S, myid) result(failure) + integer(c_int) function Test_FSUNLinSolNumIters(S, myid) result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver), pointer :: S - integer(C_INT) :: myid - integer(C_INT) :: numiters + integer(c_int) :: myid + integer(c_int) :: numiters failure = 0 @@ -105,116 +102,107 @@ integer(C_INT) function Test_FSUNLinSolNumIters(S, myid) result(failure) numiters = FSUNLinSolNumIters(S) if (myid == 0) then - write(*,'(A,I0,A)') " PASSED test -- FSUNLinSolNumIters (", numiters, ")" + write (*, '(A,I0,A)') " PASSED test -- FSUNLinSolNumIters (", numiters, ")" end if end function Test_FSUNLinSolNumIters - - integer(C_INT) function Test_FSUNLinSolResNorm(S, myid) result(failure) + integer(c_int) function Test_FSUNLinSolResNorm(S, myid) result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver), pointer :: S - integer(C_INT) :: myid - real(C_DOUBLE) :: resnorm + integer(c_int) :: myid + real(c_double) :: resnorm failure = 0 resnorm = FSUNLinSolResNorm(S) if (resnorm < ZERO) then - write(*,'(A,E14.7,A,I0)') & + write (*, '(A,E14.7,A,I0)') & ">>> FAILED test -- FSUNLinSolSolve returned ", resnorm, ", Proc ", myid else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolResNorm " + write (*, *) " PASSED test -- FSUNLinSolResNorm " end if end function Test_FSUNLinSolResNorm - - integer(C_INT) function Test_FSUNLinSolResid(S, myid) result(failure) + integer(c_int) function Test_FSUNLinSolResid(S, myid) result(failure) use, intrinsic :: iso_c_binding - - implicit none type(SUNLinearSolver), pointer :: S - integer(C_INT) :: myid - type(N_Vector), pointer :: resid + integer(c_int) :: myid + type(N_Vector), pointer :: resid failure = 0 resid => FSUNLinSolResid(S) if (.not. associated(resid)) then - write(*,*) ">>> FAILED test -- FSUNLinSolResid returned NULL N_Vector, Proc ", myid + write (*, *) ">>> FAILED test -- FSUNLinSolResid returned NULL N_Vector, Proc ", myid else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolResid " + write (*, *) " PASSED test -- FSUNLinSolResid " end if end function Test_FSUNLinSolResid - - integer(C_INT) function Test_FSUNLinSolSetATimes(S, ATdata, ATimes, myid) & + integer(c_int) function Test_FSUNLinSolSetATimes(S, ATdata, ATimes, myid) & result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver), pointer :: S - type(C_PTR) :: ATdata - type(C_FUNPTR) :: ATimes - integer(C_INT) :: myid + type(c_ptr) :: ATdata + type(c_funptr) :: ATimes + integer(c_int) :: myid failure = 0 ! try calling SetATimes routine: should pass/fail based on expected input - failure = FSUNLinSolSetATimes(S, ATdata, ATimes); - + failure = FSUNLinSolSetATimes(S, ATdata, ATimes); if (failure /= 0) then - write(*,'(A,I0,A,I0)') & + write (*, '(A,I0,A,I0)') & ">>> FAILED test -- FSUNLinSolSetATimes returned ", failure, ", Proc ", myid failure = 1 else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolSetATimes " + write (*, *) " PASSED test -- FSUNLinSolSetATimes " end if end function Test_FSUNLinSolSetATimes - - integer(C_INT) function Test_FSUNLinSolSetPreconditioner(S, Pdata, PSetup, PSolve, myid) & + integer(c_int) function Test_FSUNLinSolSetPreconditioner(S, Pdata, PSetup, PSolve, myid) & result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver), pointer :: S - type(C_PTR) :: Pdata - type(C_FUNPTR) :: PSetup, PSolve - integer(C_INT) :: myid + type(c_ptr) :: Pdata + type(c_funptr) :: PSetup, PSolve + integer(c_int) :: myid ! try calling SetPreconditioner routine: should pass/fail based on expected input - failure = FSUNLinSolSetPreconditioner(S, Pdata, PSetup, PSolve); - + failure = FSUNLinSolSetPreconditioner(S, Pdata, PSetup, PSolve); if (failure /= 0) then - write(*,'(A,I0,A,I0)') & + write (*, '(A,I0,A,I0)') & ">>> FAILED test -- FSUNLinSolSetPreconditioner returned ", failure, ", Proc ", myid failure = 1 else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolSetPreconditioner " + write (*, *) " PASSED test -- FSUNLinSolSetPreconditioner " end if end function Test_FSUNLinSolSetPreconditioner - - integer(C_INT) function Test_FSUNLinSolSetScalingVectors(S, s1, s2, myid) & + integer(c_int) function Test_FSUNLinSolSetScalingVectors(S, s1, s2, myid) & result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver) :: S type(N_Vector) :: s1, s2 - integer(C_INT) :: myid + integer(c_int) :: myid failure = 0 @@ -222,55 +210,54 @@ integer(C_INT) function Test_FSUNLinSolSetScalingVectors(S, s1, s2, myid) & failure = FSUNLinSolSetScalingVectors(S, s1, s2) if (failure /= 0) then - write(*,'(A,I0,A,I0)') & + write (*, '(A,I0,A,I0)') & ">>> FAILED test -- FSUNLinSolSetScalingVectors returned ", failure, ", Proc ", myid failure = 1 else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolSetScalingVectors " + write (*, *) " PASSED test -- FSUNLinSolSetScalingVectors " end if end function Test_FSUNLinSolSetScalingVectors - - integer(C_INT) function Test_FSUNLinSolInitialize(S, myid) result(failure) + integer(c_int) function Test_FSUNLinSolInitialize(S, myid) result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver) :: S - integer(C_INT) :: myid + integer(c_int) :: myid failure = 0 failure = FSUNLinSolInitialize(S) if (failure /= 0) then - write(*,'(A,I0,A,I0)') & + write (*, '(A,I0,A,I0)') & ">>> FAILED test -- FSUNLinSolInitialize returned ", failure, ", Proc ", myid failure = 1 else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolInitialize " + write (*, *) " PASSED test -- FSUNLinSolInitialize " end if end function Test_FSUNLinSolInitialize - integer(C_INT) function Test_FSUNLinSolSetup(S, A, myid) result(failure) + integer(c_int) function Test_FSUNLinSolSetup(S, A, myid) result(failure) use, intrinsic :: iso_c_binding implicit none type(SUNLinearSolver) :: S type(SUNMatrix) :: A - integer(C_INT) :: myid + integer(c_int) :: myid failure = 0 failure = FSUNLinSolSetup(S, A) if (failure /= 0) then - write(*,'(A,I0,A,I0)') & + write (*, '(A,I0,A,I0)') & ">>> FAILED test -- FSUNLinSolSetup returned ", failure, ", Proc ", myid failure = 1 else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolSetup " + write (*, *) " PASSED test -- FSUNLinSolSetup " end if end function Test_FSUNLinSolSetup @@ -283,7 +270,7 @@ end function Test_FSUNLinSolSetup ! while the 'A' that is supplied to this function should have been ! 'setup' by the Test_FSUNLinSolSetup() function prior to this call. ! ---------------------------------------------------------------------- - integer(C_INT) function Test_FSUNLinSolSolve(S, A, x, b, tol, myid) result(failure) + integer(c_int) function Test_FSUNLinSolSolve(S, A, x, b, tol, myid) result(failure) use, intrinsic :: iso_c_binding implicit none @@ -291,8 +278,8 @@ integer(C_INT) function Test_FSUNLinSolSolve(S, A, x, b, tol, myid) result(failu type(SUNMatrix) :: A type(N_Vector) :: x, b type(N_Vector), pointer :: y - real(C_DOUBLE) :: tol - integer(C_INT) :: myid + real(c_double) :: tol + integer(c_int) :: myid failure = 0 @@ -303,7 +290,7 @@ integer(C_INT) function Test_FSUNLinSolSolve(S, A, x, b, tol, myid) result(failu ! perform solve failure = FSUNLinSolSolve(S, A, y, b, tol) if (failure /= 0) then - write(*,'(A,I0,A,I0)') & + write (*, '(A,I0,A,I0)') & ">>> FAILED test -- FSUNLinSolSolve returned ", failure, ", Proc ", myid return end if @@ -313,9 +300,9 @@ integer(C_INT) function Test_FSUNLinSolSolve(S, A, x, b, tol, myid) result(failu call FN_VScale(ONE, y, x) if (failure /= 0) then - write(*,*) ">>> FAILED test -- FSUNLinSolSolve check, Proc ", myid + write (*, *) ">>> FAILED test -- FSUNLinSolSolve check, Proc ", myid else if (myid == 0) then - write(*,*) " PASSED test -- FSUNLinSolSolve" + write (*, *) " PASSED test -- FSUNLinSolSolve" end if call FN_VDestroy(y) diff --git a/examples/sunmatrix/band/test_fsunmatrix_band_mod.f90 b/examples/sunmatrix/band/test_fsunmatrix_band_mod.f90 index 3fc4bff7a4..f7c7e00bca 100644 --- a/examples/sunmatrix/band/test_fsunmatrix_band_mod.f90 +++ b/examples/sunmatrix/band/test_fsunmatrix_band_mod.f90 @@ -20,20 +20,17 @@ module test_fsunmatrix_band use test_utilities implicit none - - - integer(kind=myindextype), parameter :: N = 10 + integer(kind=myindextype), parameter :: N = 10 integer(kind=myindextype), parameter :: mu = 2 integer(kind=myindextype), parameter :: ml = 2 contains - integer(C_INT) function smoke_tests() result(fails) + integer(c_int) function smoke_tests() result(fails) !======== Inclusions ========== use, intrinsic :: iso_c_binding - use fsunmatrix_band_mod use fnvector_serial_mod @@ -42,11 +39,11 @@ integer(C_INT) function smoke_tests() result(fails) ! local variables type(SUNMatrix), pointer :: A, B ! SUNMatrix - type(N_Vector), pointer :: x, y ! NVectors - real(C_DOUBLE), pointer :: matdat(:) ! matrix data pointer - integer(C_LONG) :: lenrw(1), leniw(1) ! matrix real and int work space size - integer(C_LONG) :: val - type(C_PTR), pointer :: cptr + type(N_Vector), pointer :: x, y ! NVectors + real(c_double), pointer :: matdat(:) ! matrix data pointer + integer(c_long) :: lenrw(1), leniw(1) ! matrix real and int work space size + integer(c_long) :: val + type(c_ptr), pointer :: cptr fails = 0 x => FN_VNew_Serial(N, sunctx) @@ -57,7 +54,7 @@ integer(C_INT) function smoke_tests() result(fails) ! constructor A => FSUNBandMatrix(N, mu, ml, sunctx) if (.not. associated(A)) then - print *,'>>> FAILED - ERROR in FSUNBandMatrix; halting' + print *, '>>> FAILED - ERROR in FSUNBandMatrix; halting' fails = 1 return end if @@ -71,18 +68,18 @@ integer(C_INT) function smoke_tests() result(fails) val = FSUNBandMatrix_StoredUpperBandwidth(A) val = FSUNBandMatrix_LDim(A) matdat => FSUNBandMatrix_Data(A) - cptr => FSUNBandMatrix_Cols(A) + cptr => FSUNBandMatrix_Cols(A) matdat => FSUNBandMatrix_Column(A, N) ! matrix operations B => FSUNMatClone_Band(A) if (.not. associated(B)) then - print *,'>>> FAILED - ERROR in FSUNMatClone_Band; halting' + print *, '>>> FAILED - ERROR in FSUNMatClone_Band; halting' fails = 1 return end if fails = fails + FSUNMatZero_Band(A) - fails = fails + FSUNMatCopy_Band(A,B) + fails = fails + FSUNMatCopy_Band(A, B) fails = fails + FSUNMatScaleAdd_Band(ONE, A, B) fails = fails + FSUNMatScaleAddI_Band(ONE, A) fails = fails + FSUNMatMatvec_Band(A, x, y) @@ -96,10 +93,9 @@ integer(C_INT) function smoke_tests() result(fails) end function smoke_tests - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - use fnvector_serial_mod use fsunmatrix_band_mod @@ -108,8 +104,8 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNMatrix), pointer :: A, I - type(N_Vector), pointer :: x, y - real(C_DOUBLE), pointer :: Adata(:), Idata(:), xdata(:), ydata(:) + type(N_Vector), pointer :: x, y + real(c_double), pointer :: Adata(:), Idata(:), xdata(:), ydata(:) integer(kind=myindextype) :: ii, jj, smu, istart, iend, offset fails = 0 @@ -126,14 +122,14 @@ integer(C_INT) function unit_tests() result(fails) end do ! Fill A matrix - smu = FSUNBandMatrix_StoredUpperBandwidth(A) + smu = FSUNBandMatrix_StoredUpperBandwidth(A) Adata => FSUNBandMatrix_Data(A) do jj = 1, N - offset = (jj-1)*(smu+ml+1) + smu + 1 ! offset to diagonal - istart = merge(-mu, -(jj-1), jj > mu) ! above diagonal - iend = merge(N-jj , ml, jj > N - ml) ! below diagonal + offset = (jj - 1)*(smu + ml + 1) + smu + 1 ! offset to diagonal + istart = merge(-mu, -(jj - 1), jj > mu) ! above diagonal + iend = merge(N - jj, ml, jj > N - ml) ! below diagonal do ii = istart, iend - Adata(offset+ii) = (jj-1) - ii + Adata(offset + ii) = (jj - 1) - ii end do end do @@ -141,15 +137,15 @@ integer(C_INT) function unit_tests() result(fails) ydata => FN_VGetArrayPointer(y) ! Fill vectors - do jj = 0, N-1 + do jj = 0, N - 1 ! x vector - xdata(jj+1) = jj + xdata(jj + 1) = jj ! y vector - ydata(jj+1) = ZERO - istart = max(0_myindextype, jj-ml) - iend = min(N-1, jj+mu) + ydata(jj + 1) = ZERO + istart = max(0_myindextype, jj - ml) + iend = min(N - 1, jj + mu) do ii = istart, iend - ydata(jj+1) = ydata(jj+1) + (ii+ii-jj)*(ii) + ydata(jj + 1) = ydata(jj + 1) + (ii + ii - jj)*(ii) end do end do @@ -179,7 +175,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'Band SUNMatrix Fortran 2003 interface test' @@ -199,7 +195,7 @@ program main end program main ! exported functions used by test_sunmatrix -integer(C_INT) function check_matrix(B, A, tol) result(fails) +integer(c_int) function check_matrix(B, A, tol) result(fails) use, intrinsic :: iso_c_binding use fsunmatrix_band_mod @@ -208,16 +204,16 @@ integer(C_INT) function check_matrix(B, A, tol) result(fails) implicit none type(SUNMatrix) :: A, B - real(C_DOUBLE) :: tol - real(C_DOUBLE), pointer :: Adata(:), Bdata(:) - integer(C_LONG) :: N, smu, mu, ml, ii, istart, iend, jj, offset + real(c_double) :: tol + real(c_double), pointer :: Adata(:), Bdata(:) + integer(c_long) :: N, smu, mu, ml, ii, istart, iend, jj, offset fails = 0 - N = FSUNBandMatrix_Columns(A) + N = FSUNBandMatrix_Columns(A) smu = FSUNBandMatrix_StoredUpperBandwidth(A) - mu = FSUNBandMatrix_UpperBandwidth(A) - ml = FSUNBandMatrix_LowerBandwidth(A) + mu = FSUNBandMatrix_UpperBandwidth(A) + ml = FSUNBandMatrix_LowerBandwidth(A) if (FSUNMatGetID(A) /= FSUNMatGetID(B)) then fails = 1 @@ -252,17 +248,17 @@ integer(C_INT) function check_matrix(B, A, tol) result(fails) Adata => FSUNBandMatrix_Data(A) Bdata => FSUNBandMatrix_Data(B) do jj = 1, N - offset = (jj-1)*(smu+ml+1) + smu + 1 ! offset to diagonal - istart = merge(-mu, -(jj-1), jj > mu) ! above diagonal - iend = merge(N-jj , ml, jj > N - ml) ! below diagonal + offset = (jj - 1)*(smu + ml + 1) + smu + 1 ! offset to diagonal + istart = merge(-mu, -(jj - 1), jj > mu) ! above diagonal + iend = merge(N - jj, ml, jj > N - ml) ! below diagonal do ii = istart, iend - fails = fails + FNEQTOL(Adata(offset+ii), Bdata(offset+ii), tol) + fails = fails + FNEQTOL(Adata(offset + ii), Bdata(offset + ii), tol) end do end do end function check_matrix -integer(C_INT) function check_matrix_entry(A, c, tol) result(fails) +integer(c_int) function check_matrix_entry(A, c, tol) result(fails) use, intrinsic :: iso_c_binding use fsunmatrix_band_mod @@ -271,27 +267,27 @@ integer(C_INT) function check_matrix_entry(A, c, tol) result(fails) implicit none type(SUNMatrix) :: A - real(C_DOUBLE) :: c, tol - real(C_DOUBLE), pointer :: Adata(:) - integer(C_LONG) :: N, smu, mu, ml, ii, istart, iend, jj, offset + real(c_double) :: c, tol + real(c_double), pointer :: Adata(:) + integer(c_long) :: N, smu, mu, ml, ii, istart, iend, jj, offset fails = 0 - N = FSUNBandMatrix_Columns(A) + N = FSUNBandMatrix_Columns(A) smu = FSUNBandMatrix_StoredUpperBandwidth(A) - mu = FSUNBandMatrix_UpperBandwidth(A) - ml = FSUNBandMatrix_LowerBandwidth(A) + mu = FSUNBandMatrix_UpperBandwidth(A) + ml = FSUNBandMatrix_LowerBandwidth(A) Adata => FSUNBandMatrix_Data(A) do jj = 1, N - offset = (jj-1)*(smu+ml+1) + smu + 1 ! offset to diagonal - istart = merge(-mu, -(jj-1), jj > mu) ! above diagonal - iend = merge(N-jj , ml, jj > N - ml) ! below diagonal + offset = (jj - 1)*(smu + ml + 1) + smu + 1 ! offset to diagonal + istart = merge(-mu, -(jj - 1), jj > mu) ! above diagonal + iend = merge(N - jj, ml, jj > N - ml) ! below diagonal do ii = istart, iend - if (FNEQTOL(Adata(offset+ii), c, tol) /= 0) then + if (FNEQTOL(Adata(offset + ii), c, tol) /= 0) then fails = fails + 1 - write(*,'(A,E10.1,A,E14.7,A,I9,A,E14.7)') "tol = ", tol, & - " c = ", c, " data[", offset+ii, "] = ", Adata(offset+ii) + write (*, '(A,E10.1,A,E14.7,A,I9,A,E14.7)') "tol = ", tol, & + " c = ", c, " data[", offset + ii, "] = ", Adata(offset + ii) end if end do end do diff --git a/examples/sunmatrix/dense/test_fsunmatrix_dense_mod.f90 b/examples/sunmatrix/dense/test_fsunmatrix_dense_mod.f90 index 87cac2dff5..2a8a39ebbb 100644 --- a/examples/sunmatrix/dense/test_fsunmatrix_dense_mod.f90 +++ b/examples/sunmatrix/dense/test_fsunmatrix_dense_mod.f90 @@ -24,12 +24,11 @@ module test_fsunmatrix_dense contains - integer(C_INT) function smoke_tests() result(fails) + integer(c_int) function smoke_tests() result(fails) !======== Inclusions ========== use, intrinsic :: iso_c_binding - use fsunmatrix_dense_mod use fnvector_serial_mod @@ -38,10 +37,10 @@ integer(C_INT) function smoke_tests() result(fails) ! local variables type(SUNMatrix), pointer :: A, B ! SUNMatrix - type(N_Vector), pointer :: x, y ! NVectors - real(C_DOUBLE), pointer :: matdat(:) ! matrix data pointer - integer(C_LONG) :: lenrw(1), leniw(1) ! matrix real and int work space size - integer(C_LONG) :: val + type(N_Vector), pointer :: x, y ! NVectors + real(c_double), pointer :: matdat(:) ! matrix data pointer + integer(c_long) :: lenrw(1), leniw(1) ! matrix real and int work space size + integer(c_long) :: val fails = 0 @@ -53,7 +52,7 @@ integer(C_INT) function smoke_tests() result(fails) ! constructor A => FSUNDenseMatrix(N, N, sunctx) if (.not. associated(A)) then - print *,'>>> FAILED - ERROR in FSUNDenseMatrix; halting' + print *, '>>> FAILED - ERROR in FSUNDenseMatrix; halting' stop 1 end if @@ -63,16 +62,16 @@ integer(C_INT) function smoke_tests() result(fails) val = FSUNDenseMatrix_Columns(A) val = FSUNDenseMatrix_LData(A) matdat => FSUNDenseMatrix_Data(A) - matdat => FSUNDenseMatrix_Column(A,N) + matdat => FSUNDenseMatrix_Column(A, N) ! matrix operations B => FSUNMatClone_Dense(A) if (.not. associated(B)) then - print *,'>>> FAILED - ERROR in FSUNMatClone_Dense; halting' + print *, '>>> FAILED - ERROR in FSUNMatClone_Dense; halting' stop 1 end if fails = fails + FSUNMatZero_Dense(A) - fails = fails + FSUNMatCopy_Dense(A,B) + fails = fails + FSUNMatCopy_Dense(A, B) fails = fails + FSUNMatScaleAdd_Dense(ONE, A, B) fails = fails + FSUNMatScaleAddI_Dense(ONE, A) fails = fails + FSUNMatMatvec_Dense(A, x, y) @@ -86,10 +85,9 @@ integer(C_INT) function smoke_tests() result(fails) end function smoke_tests - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - use fnvector_serial_mod use fsunmatrix_dense_mod use test_sunmatrix @@ -97,9 +95,9 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNMatrix), pointer :: A, I - type(N_Vector), pointer :: x, y - real(C_DOUBLE), pointer :: Adata(:), Idata(:), xdata(:), ydata(:) - integer(C_LONG) :: ii, jj, tmp1, tmp2 + type(N_Vector), pointer :: x, y + real(c_double), pointer :: Adata(:), Idata(:), xdata(:), ydata(:) + integer(c_long) :: ii, jj, tmp1, tmp2 fails = 0 @@ -110,30 +108,30 @@ integer(C_INT) function unit_tests() result(fails) ! fill matrix A Adata => FSUNDenseMatrix_Data(A) - do jj=1, N - do ii=1, N - Adata((jj-1)*N + ii) = jj*(ii+jj-2) + do jj = 1, N + do ii = 1, N + Adata((jj - 1)*N + ii) = jj*(ii + jj - 2) end do end do ! fill matrix I (identity) Idata => FSUNDenseMatrix_Data(I) - do jj=1, N - Idata((jj-1)*N + jj) = ONE + do jj = 1, N + Idata((jj - 1)*N + jj) = ONE end do ! fill vector x xdata => FN_VGetArrayPointer(x) - do ii=1, N - xdata(ii) = ONE / ii + do ii = 1, N + xdata(ii) = ONE/ii end do ! fill vector y ydata => FN_VGetArrayPointer(y) - do ii=1, N - tmp1 = ii-1 + do ii = 1, N + tmp1 = ii - 1 tmp2 = tmp1 + N - 1 - ydata(ii) = HALF*(tmp2+1-tmp1)*(tmp1+tmp2) + ydata(ii) = HALF*(tmp2 + 1 - tmp1)*(tmp1 + tmp2) end do fails = fails + Test_FSUNMatGetID(A, SUNMATRIX_DENSE, 0) @@ -162,7 +160,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'Dense SUNMatrix Fortran 2003 interface test' @@ -182,7 +180,7 @@ program main end program main ! exported functions used by test_sunmatrix -integer(C_INT) function check_matrix(A, B, tol) result(fails) +integer(c_int) function check_matrix(A, B, tol) result(fails) use, intrinsic :: iso_c_binding use fsunmatrix_dense_mod @@ -190,11 +188,9 @@ integer(C_INT) function check_matrix(A, B, tol) result(fails) implicit none - - type(SUNMatrix) :: A, B - real(C_DOUBLE) :: tol - real(C_DOUBLE), pointer :: Adata(:), Bdata(:) + real(c_double) :: tol + real(c_double), pointer :: Adata(:), Bdata(:) integer(kind=myindextype) :: Aldata, Bldata, i fails = 0 @@ -214,13 +210,13 @@ integer(C_INT) function check_matrix(A, B, tol) result(fails) end if ! compare data - do i=1, Aldata + do i = 1, Aldata fails = fails + FNEQTOL(Adata(i), Bdata(i), tol) end do end function check_matrix -integer(C_INT) function check_matrix_entry(A, c, tol) result(fails) +integer(c_int) function check_matrix_entry(A, c, tol) result(fails) use, intrinsic :: iso_c_binding use fsunmatrix_dense_mod @@ -229,9 +225,9 @@ integer(C_INT) function check_matrix_entry(A, c, tol) result(fails) implicit none type(SUNMatrix) :: A - real(C_DOUBLE) :: c, tol - real(C_DOUBLE), pointer :: Adata(:) - integer(C_LONG) :: Aldata, i + real(c_double) :: c, tol + real(c_double), pointer :: Adata(:) + integer(c_long) :: Aldata, i fails = 0 @@ -242,16 +238,16 @@ integer(C_INT) function check_matrix_entry(A, c, tol) result(fails) Aldata = FSUNDenseMatrix_LData(A) ! compare data - do i=1, Aldata + do i = 1, Aldata fails = fails + FNEQTOL(Adata(i), c, tol) end do if (fails > ZERO) then print *, ">>> ERROR: check_matrix_entry failures: " - do i=1, Aldata + do i = 1, Aldata if (FNEQTOL(Adata(i), c, tol) /= 0) then - write(*,'(A,I0,A,E14.7,A,E14.7)') & - "Adata[ ", i, "] =", Adata(i) ," c = ", c + write (*, '(A,I0,A,E14.7,A,E14.7)') & + "Adata[ ", i, "] =", Adata(i), " c = ", c end if end do end if diff --git a/examples/sunmatrix/sparse/test_fsunmatrix_sparse_mod.f90 b/examples/sunmatrix/sparse/test_fsunmatrix_sparse_mod.f90 index 3283cd637e..03bcff5896 100644 --- a/examples/sunmatrix/sparse/test_fsunmatrix_sparse_mod.f90 +++ b/examples/sunmatrix/sparse/test_fsunmatrix_sparse_mod.f90 @@ -24,12 +24,11 @@ module test_fsunmatrix_sparse contains - integer(C_INT) function smoke_tests() result(fails) + integer(c_int) function smoke_tests() result(fails) !======== Inclusions ========== use, intrinsic :: iso_c_binding - use fsunmatrix_sparse_mod use fnvector_serial_mod @@ -38,13 +37,13 @@ integer(C_INT) function smoke_tests() result(fails) ! local variables type(SUNMatrix), pointer :: A, B ! SUNMatrix - type(N_Vector), pointer :: x, y ! NVectors - real(C_DOUBLE), pointer :: matdat(:) ! matrix data pointer + type(N_Vector), pointer :: x, y ! NVectors + real(c_double), pointer :: matdat(:) ! matrix data pointer integer(kind=myindextype), pointer :: inddat(:) ! indices pointer - integer(C_LONG) :: lenrw(1), leniw(1) ! matrix real and int work space size + integer(c_long) :: lenrw(1), leniw(1) ! matrix real and int work space size integer(kind=myindextype) :: tmp1 - integer(C_INT) :: tmp2 + integer(c_int) :: tmp2 fails = 0 @@ -56,7 +55,7 @@ integer(C_INT) function smoke_tests() result(fails) ! constructor A => FSUNSparseMatrix(N, N, N*N, CSR_MAT, sunctx) if (.not. associated(A)) then - print *,'>>> FAILED - ERROR in FSUNSparseMatrix; halting' + print *, '>>> FAILED - ERROR in FSUNSparseMatrix; halting' stop 1 end if @@ -74,7 +73,7 @@ integer(C_INT) function smoke_tests() result(fails) ! matrix operations B => FSUNMatClone_Sparse(A) if (.not. associated(B)) then - print *,'>>> FAILED - ERROR in FSUNMatClone_Sparse; halting' + print *, '>>> FAILED - ERROR in FSUNMatClone_Sparse; halting' stop 1 end if fails = fails + FSUNMatZero_Sparse(A) @@ -92,10 +91,9 @@ integer(C_INT) function smoke_tests() result(fails) end function smoke_tests - integer(C_INT) function unit_tests() result(fails) + integer(c_int) function unit_tests() result(fails) use, intrinsic :: iso_c_binding - use fnvector_serial_mod use fsunmatrix_dense_mod use fsunmatrix_sparse_mod @@ -104,9 +102,9 @@ integer(C_INT) function unit_tests() result(fails) implicit none type(SUNMatrix), pointer :: DA, DI, A, I - type(N_Vector), pointer :: x, y - real(C_DOUBLE), pointer :: Adata(:), Idata(:), xdata(:), ydata(:) - integer(C_LONG) :: ii, jj, tmp1, tmp2 + type(N_Vector), pointer :: x, y + real(c_double), pointer :: Adata(:), Idata(:), xdata(:), ydata(:) + integer(c_long) :: ii, jj, tmp1, tmp2 fails = 0 @@ -116,16 +114,16 @@ integer(C_INT) function unit_tests() result(fails) ! fill A matrix Adata => FSUNDenseMatrix_Data(DA) - do jj=1, N - do ii=1, N - Adata((jj-1)*N + ii) = jj*(ii+jj-2) + do jj = 1, N + do ii = 1, N + Adata((jj - 1)*N + ii) = jj*(ii + jj - 2) end do end do ! fill identity matrix Idata => FSUNDenseMatrix_Data(DI) - do jj=1, N - Idata((jj-1)*N + jj) = ONE + do jj = 1, N + Idata((jj - 1)*N + jj) = ONE end do ! create sparse versions of A and I @@ -138,16 +136,16 @@ integer(C_INT) function unit_tests() result(fails) ! fill vector x xdata => FN_VGetArrayPointer(x) - do ii=1, N - xdata(ii) = ONE / ii + do ii = 1, N + xdata(ii) = ONE/ii end do ! fill vector y ydata => FN_VGetArrayPointer(y) - do ii=1, N - tmp1 = ii-1 + do ii = 1, N + tmp1 = ii - 1 tmp2 = tmp1 + N - 1 - ydata(ii) = HALF*(tmp2+1-tmp1)*(tmp1+tmp2) + ydata(ii) = HALF*(tmp2 + 1 - tmp1)*(tmp1 + tmp2) end do fails = fails + Test_FSUNMatGetID(A, SUNMATRIX_SPARSE, 0) @@ -178,7 +176,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= print *, 'Sparse SUNMatrix Fortran 2003 interface test' @@ -198,7 +196,7 @@ program main end program main ! exported functions used by test_sunmatrix -integer(C_INT) function check_matrix(A, B, tol) result(fails) +integer(c_int) function check_matrix(A, B, tol) result(fails) use, intrinsic :: iso_c_binding use fsunmatrix_sparse_mod @@ -206,18 +204,17 @@ integer(C_INT) function check_matrix(A, B, tol) result(fails) implicit none - type(SUNMatrix) :: A, B - real(C_DOUBLE) :: tol - real(C_DOUBLE), pointer :: Adata(:), Bdata(:) + real(c_double) :: tol + real(c_double), pointer :: Adata(:), Bdata(:) integer(kind=myindextype), pointer :: Aidxvals(:), Bidxvals(:) integer(kind=myindextype), pointer :: Aidxptrs(:), Bidxptrs(:) integer(kind=myindextype) :: i, np, Annz, Bnnz fails = 0 - Adata => FSUNSparseMatrix_Data(A) - Bdata => FSUNSparseMatrix_Data(B) + Adata => FSUNSparseMatrix_Data(A) + Bdata => FSUNSparseMatrix_Data(B) Aidxvals => FSUNSparseMatrix_IndexValues(A) Bidxvals => FSUNSparseMatrix_IndexValues(B) Aidxptrs => FSUNSparseMatrix_IndexPointers(A) @@ -225,7 +222,7 @@ integer(C_INT) function check_matrix(A, B, tol) result(fails) Annz = FSUNSparseMatrix_NNZ(A) Bnnz = FSUNSparseMatrix_NNZ(B) - np = FSUNSparseMatrix_NP(A) + np = FSUNSparseMatrix_NP(A) if (FSUNMatGetID(A) /= FSUNMatGetID(B)) then fails = 1 @@ -282,10 +279,9 @@ integer(C_INT) function check_matrix(A, B, tol) result(fails) return end if - end function check_matrix -integer(C_INT) function check_matrix_entry(A, c, tol) result(fails) +integer(c_int) function check_matrix_entry(A, c, tol) result(fails) use, intrinsic :: iso_c_binding use fsunmatrix_sparse_mod @@ -294,28 +290,27 @@ integer(C_INT) function check_matrix_entry(A, c, tol) result(fails) implicit none type(SUNMatrix) :: A - real(C_DOUBLE) :: c, tol - real(C_DOUBLE), pointer :: Adata(:) + real(c_double) :: c, tol + real(c_double), pointer :: Adata(:) integer(kind=myindextype), pointer :: Aidxptrs(:) integer(kind=myindextype) :: i, np fails = 0 - Adata => FSUNSparseMatrix_Data(A) + Adata => FSUNSparseMatrix_Data(A) Aidxptrs => FSUNSparseMatrix_IndexPointers(A) np = FSUNSparseMatrix_NP(A) ! compare data - do i=1, Aidxptrs(np) + do i = 1, Aidxptrs(np) if (FNEQTOL(Adata(i), c, tol) /= 0) then fails = fails + 1 - write(*,'(A,I0,A,E14.7,A,E14.7)') & + write (*, '(A,I0,A,E14.7,A,E14.7)') & 'Adata(', i, ') = ', Adata(i), ' c = ', c end if end do - end function check_matrix_entry logical function is_square(A) result(res) diff --git a/examples/sunmatrix/test_sunmatrix.f90 b/examples/sunmatrix/test_sunmatrix.f90 index 1f1cc3319b..30c1f5f2ca 100644 --- a/examples/sunmatrix/test_sunmatrix.f90 +++ b/examples/sunmatrix/test_sunmatrix.f90 @@ -23,17 +23,14 @@ module test_sunmatrix use, intrinsic :: iso_c_binding use test_utilities - - - implicit none logical, parameter :: print_all_ranks = .false. ! functions implemented in specific matrix tests - integer(C_INT), external :: check_matrix - integer(C_INT), external :: check_matrix_entry - logical, external :: is_square + integer(c_int), external :: check_matrix + integer(c_int), external :: check_matrix_entry + logical, external :: is_square contains @@ -43,12 +40,12 @@ subroutine TEST_STATUS(frmt, myrank) implicit none character(LEN=*) :: frmt - integer(C_INT) :: myrank + integer(c_int) :: myrank if (print_all_ranks) then - write(*,'(A,I0,A,A)') 'process ', myrank, ': ', frmt + write (*, '(A,I0,A,A)') 'process ', myrank, ': ', frmt else - write(*,*) frmt + write (*, *) frmt end if end subroutine TEST_STATUS @@ -59,26 +56,26 @@ subroutine TEST_STATUS2(frmt, retval, myrank) implicit none character(LEN=*) :: frmt - integer(C_INT) :: myrank - integer(C_INT) :: retval + integer(c_int) :: myrank + integer(c_int) :: retval if (print_all_ranks) then - write(*,'(A,I0,A,A,I0)') 'process ', myrank, ': ', frmt, retval + write (*, '(A,I0,A,A,I0)') 'process ', myrank, ': ', frmt, retval else - write(*,'(A,I0)') frmt, retval + write (*, '(A,I0)') frmt, retval end if end subroutine TEST_STATUS2 - integer(C_INT) function check_vector(x, y, tol) result(failure) + integer(c_int) function check_vector(x, y, tol) result(failure) use, intrinsic :: iso_c_binding implicit none type(N_Vector) :: x, y - real(C_DOUBLE) :: tol - integer(C_LONG) :: i, xlen, ylen - real(C_DOUBLE), pointer :: xdata(:), ydata(:) + real(c_double) :: tol + integer(c_long) :: i, xlen, ylen + real(c_double), pointer :: xdata(:), ydata(:) failure = 0 @@ -100,16 +97,15 @@ integer(C_INT) function check_vector(x, y, tol) result(failure) end function check_vector - integer(C_INT) function Test_FSUNMatGetID(A, sunid, myid) result(failure) + integer(c_int) function Test_FSUNMatGetID(A, sunid, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none type(SUNMatrix) :: A integer(SUNMatrix_ID) :: sunid, mysunid - integer(C_INT) :: myid + integer(c_int) :: myid failure = 0 @@ -128,16 +124,15 @@ end function Test_FSUNMatGetID ! SUNMatClone Test ! NOTE: This routine depends on SUNMatCopy to check matrix data. ! -------------------------------------------------------------------- - integer(C_INT) function Test_FSUNMatClone(A, myid) result(failure) + integer(c_int) function Test_FSUNMatClone(A, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none - integer(C_INT) :: myid + integer(c_int) :: myid type(SUNMatrix) :: A - real(C_DOUBLE) :: tol = 10*SUN_UNIT_ROUNDOFF + real(c_double) :: tol = 10*SUN_UNIT_ROUNDOFF type(SUNMatrix), pointer :: B failure = 0 @@ -172,15 +167,14 @@ integer(C_INT) function Test_FSUNMatClone(A, myid) result(failure) end function Test_FSUNMatClone - integer(C_INT) function Test_FSUNMatZero(A, myid) result(failure) + integer(c_int) function Test_FSUNMatZero(A, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none - integer(C_INT) :: myid - real(C_DOUBLE) :: tol = 10*SUN_UNIT_ROUNDOFF + integer(c_int) :: myid + real(c_double) :: tol = 10*SUN_UNIT_ROUNDOFF type(SUNMatrix) :: A type(SUNMatrix), pointer :: B @@ -197,7 +191,7 @@ integer(C_INT) function Test_FSUNMatZero(A, myid) result(failure) end if ! A data should be a vector of zeros - failure = check_matrix_entry(B, ZERO, tol); + failure = check_matrix_entry(B, ZERO, tol); if (failure /= 0) then call TEST_STATUS(">>> FAILED test -- SUNMatZero check ", myid) call FSUNMatDestroy(B) @@ -210,15 +204,14 @@ integer(C_INT) function Test_FSUNMatZero(A, myid) result(failure) end function Test_FSUNMatZero - integer(C_INT) function Test_FSUNMatCopy(A, myid) result(failure) + integer(c_int) function Test_FSUNMatCopy(A, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none - integer(C_INT) :: myid - real(C_DOUBLE) :: tol = 10*SUN_UNIT_ROUNDOFF + integer(c_int) :: myid + real(c_double) :: tol = 10*SUN_UNIT_ROUNDOFF type(SUNMatrix) :: A type(SUNMatrix), pointer :: B @@ -249,15 +242,14 @@ integer(C_INT) function Test_FSUNMatCopy(A, myid) result(failure) end function Test_FSUNMatCopy - integer(C_INT) function Test_FSUNMatScaleAdd(A, I, myid) result(failure) + integer(c_int) function Test_FSUNMatScaleAdd(A, I, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none - integer(C_INT) :: myid - real(C_DOUBLE) :: tol = 10*SUN_UNIT_ROUNDOFF + integer(c_int) :: myid + real(c_double) :: tol = 10*SUN_UNIT_ROUNDOFF type(SUNMatrix) :: A, I type(SUNMatrix), pointer :: B @@ -298,15 +290,14 @@ integer(C_INT) function Test_FSUNMatScaleAdd(A, I, myid) result(failure) end function Test_FSUNMatScaleAdd - integer(C_INT) function Test_FSUNMatScaleAddI(A, I, myid) result(failure) + integer(c_int) function Test_FSUNMatScaleAddI(A, I, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none - integer(C_INT) :: myid - real(C_DOUBLE) :: tol = 10*SUN_UNIT_ROUNDOFF + integer(c_int) :: myid + real(c_double) :: tol = 10*SUN_UNIT_ROUNDOFF type(SUNMatrix) :: A, I type(SUNMatrix), pointer :: B @@ -343,14 +334,13 @@ integer(C_INT) function Test_FSUNMatScaleAddI(A, I, myid) result(failure) end function Test_FSUNMatScaleAddI - integer(C_INT) function Test_FSUNMatMatvecSetup(A, myid) result(failure) + integer(c_int) function Test_FSUNMatMatvecSetup(A, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none - integer(C_INT) :: myid + integer(c_int) :: myid type(SUNMatrix) :: A type(SUNMatrix_Ops), pointer :: ops @@ -373,20 +363,18 @@ integer(C_INT) function Test_FSUNMatMatvecSetup(A, myid) result(failure) end function Test_FSUNMatMatvecSetup - integer(C_INT) function Test_FSUNMatMatvec(A, x, y, myid) result(failure) + integer(c_int) function Test_FSUNMatMatvec(A, x, y, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - - implicit none type(SUNMatrix) :: A type(SUNMatrix), pointer :: B type(N_Vector) :: x, y - type(N_Vector), pointer :: z, w - integer(C_INT) :: myid - real(C_DOUBLE) :: tol = 100*SUN_UNIT_ROUNDOFF + type(N_Vector), pointer :: z, w + integer(c_int) :: myid + real(c_double) :: tol = 100*SUN_UNIT_ROUNDOFF type(SUNMatrix_Ops), pointer :: ops failure = 0 @@ -425,16 +413,16 @@ integer(C_INT) function Test_FSUNMatMatvec(A, x, y, myid) result(failure) end if end if - failure = FSUNMatMatvec(B,x,z) + failure = FSUNMatMatvec(B, x, z) if (failure /= 0) then call TEST_STATUS2(">>> FAILED test -- SUNMatMatvec returned ", failure, myid) call FSUNMatDestroy(B) return end if - call FN_VLinearSum(THREE,y,ONE,x,w) + call FN_VLinearSum(THREE, y, ONE, x, w) - failure = check_vector(w,z,tol) + failure = check_vector(w, z, tol) call FSUNMatDestroy(B) call FN_VDestroy(z) @@ -444,13 +432,13 @@ integer(C_INT) function Test_FSUNMatMatvec(A, x, y, myid) result(failure) z => FN_VClone(y) - failure = FSUNMatMatvec(A,x,z) + failure = FSUNMatMatvec(A, x, z) if (failure /= 0) then call TEST_STATUS2(">>> FAILED test -- SUNMatMatvec returned ", failure, myid) return end if - failure = check_vector(y,z,tol) + failure = check_vector(y, z, tol) call FN_VDestroy(z) end if @@ -464,20 +452,19 @@ integer(C_INT) function Test_FSUNMatMatvec(A, x, y, myid) result(failure) end function Test_FSUNMatMatvec - integer(C_INT) function Test_FSUNMatSpace(A, myid) result(failure) + integer(c_int) function Test_FSUNMatSpace(A, myid) result(failure) use, intrinsic :: iso_c_binding use test_utilities - implicit none - integer(C_INT) :: myid + integer(c_int) :: myid type(SUNMatrix) :: A - integer(C_LONG) :: lenrw(1), leniw(1) + integer(c_long) :: lenrw(1), leniw(1) failure = 0 - failure = FSUNMatSpace(A, lenrw, leniw); + failure = FSUNMatSpace(A, lenrw, leniw); if (failure /= 0) then call TEST_STATUS(">>> FAILED test -- SUNMatSpace ", myid) return diff --git a/examples/sunnonlinsol/fixedpoint/test_fsunnonlinsol_fixedpoint_mod.f90 b/examples/sunnonlinsol/fixedpoint/test_fsunnonlinsol_fixedpoint_mod.f90 index 7b6cfd2322..f732b96374 100644 --- a/examples/sunnonlinsol/fixedpoint/test_fsunnonlinsol_fixedpoint_mod.f90 +++ b/examples/sunnonlinsol/fixedpoint/test_fsunnonlinsol_fixedpoint_mod.f90 @@ -22,21 +22,21 @@ module test_fsunnonlinsol_fixedpoint implicit none integer(kind=myindextype), parameter :: NEQ = 3 ! number of equations - integer(C_INT), parameter :: MAXIT = 20 ! max nonlinear iters. - real(C_DOUBLE), parameter :: TOL = 1.0e-4 ! nonlinear solver tolerance + integer(c_int), parameter :: MAXIT = 20 ! max nonlinear iters. + real(c_double), parameter :: TOL = 1.0e-4 ! nonlinear solver tolerance - real(C_DOUBLE), parameter :: PI = 3.1415926535898 + real(c_double), parameter :: PI = 3.1415926535898 ! approximate solution - real(C_DOUBLE) :: XTRUE = 0.5d0 - real(C_DOUBLE) :: YTRUE = 1.0d0 - real(C_DOUBLE) :: ZTRUE = -PI/6.0d0 + real(c_double) :: XTRUE = 0.5d0 + real(c_double) :: YTRUE = 1.0d0 + real(c_double) :: ZTRUE = -PI/6.0d0 type(N_Vector), pointer :: y0 contains - integer(C_INT) function unit_tests() result(retval) + integer(c_int) function unit_tests() result(retval) use, intrinsic :: iso_c_binding use fsundials_core_mod use fnvector_serial_mod @@ -45,10 +45,10 @@ integer(C_INT) function unit_tests() result(retval) implicit none type(SUNNonlinearSolver), pointer :: NLS ! test nonlinear solver - type(N_Vector), pointer :: ycur, ycor, w ! test vectors - real(C_DOUBLE), pointer :: data(:) - integer(C_LONG) :: niters(1) - integer(C_INT) :: tmp + type(N_Vector), pointer :: ycur, ycor, w ! test vectors + real(c_double), pointer :: data(:) + integer(c_long) :: niters(1) + integer(c_int) :: tmp y0 => FN_VNew_Serial(NEQ, sunctx) ycor => FN_VClone(y0) @@ -56,7 +56,7 @@ integer(C_INT) function unit_tests() result(retval) w => FN_VClone(y0) ! set initial guess - data => FN_VGetArrayPointer(y0) + data => FN_VGetArrayPointer(y0) data(1) = 0.1d0 data(2) = 0.1d0 data(3) = -0.1d0 @@ -72,44 +72,43 @@ integer(C_INT) function unit_tests() result(retval) retval = FSUNNonlinSolSetSysFn(NLS, c_funloc(FPFunction)) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetSysFn returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetSysFn returned ', retval return end if retval = FSUNNonlinSolSetConvTestFn(NLS, c_funloc(ConvTest), c_null_ptr) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetConvTestFn returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetConvTestFn returned ', retval return end if retval = FSUNNonlinSolSetMaxIters(NLS, MAXIT) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetMaxIters returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetMaxIters returned ', retval return end if retval = FSUNNonlinSolSolve(NLS, y0, ycor, w, TOL, 1, c_loc(y0)) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSolve returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSolve returned ', retval return end if ! update the initial guess with the final correction - call FN_VLinearSum(1.0d0, y0, 1.0d0, ycor, ycur); - + call FN_VLinearSum(1.0d0, y0, 1.0d0, ycor, ycur); ! print number of iterations retval = FSUNNonlinSolGetNumIters(NLS, niters) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolGetNumIters returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolGetNumIters returned ', retval return end if - write(*,'(A,I0)') 'Number of nonlinear iterations: ', niters(1) + write (*, '(A,I0)') 'Number of nonlinear iterations: ', niters(1) ! check answer retval = check_ans(ycur, TOL) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: check_ans failed' + write (*, '(A,I0)') ' >>> FAIL: check_ans failed' return end if @@ -122,7 +121,7 @@ integer(C_INT) function unit_tests() result(retval) end function unit_tests - integer(C_INT) function ConvTest(NLS, y, del, tol, ewt, mem) & + integer(c_int) function ConvTest(NLS, y, del, tol, ewt, mem) & result(retval) bind(C) use, intrinsic :: iso_c_binding @@ -130,9 +129,9 @@ integer(C_INT) function ConvTest(NLS, y, del, tol, ewt, mem) & type(SUNNonlinearSolver) :: NLS type(N_Vector) :: y, del, ewt - real(C_DOUBLE), value :: tol - type(C_PTR), value :: mem - real(C_DOUBLE) :: delnrm + real(c_double), value :: tol + type(c_ptr), value :: mem + real(c_double) :: delnrm ! compute the norm of the correction delnrm = FN_VMaxNorm(del) @@ -165,15 +164,15 @@ integer(C_INT) function ConvTest(NLS, y, del, tol, ewt, mem) & ! g3(x,y,z) = -1/20 exp(-x(y-1)) - (10 pi - 3) / 60 - z0 ! ! ---------------------------------------------------------------------------- - integer(C_INT) function FPFunction(ycor, f, mem) & + integer(c_int) function FPFunction(ycor, f, mem) & result(retval) bind(C) use, intrinsic :: iso_c_binding implicit none type(N_Vector) :: ycor, f - type(C_PTR), value :: mem - real(C_DOUBLE), pointer :: data(:), fdata(:) - real(C_DOUBLE) :: x, y, z + type(c_ptr), value :: mem + real(c_double), pointer :: data(:), fdata(:) + real(c_double) :: x, y, z data => FN_VGetArrayPointer(ycor) fdata => FN_VGetArrayPointer(f) @@ -182,9 +181,9 @@ integer(C_INT) function FPFunction(ycor, f, mem) & y = data(2) z = data(3) - fdata(1) = (1.0d0/3.0d0) * cos((y - 1.0d0) * z) + (1.0d0/6.0d0) - fdata(2) = (1.0d0/9.0d0) * sqrt(x*x + sin(z) + 1.06d0) + 0.9d0 - fdata(3) = -(1/20.d0) * exp(-x*(y-1.0d0)) - (10.d0 * PI - 3.0d0) / 60.0d0 + fdata(1) = (1.0d0/3.0d0)*cos((y - 1.0d0)*z) + (1.0d0/6.0d0) + fdata(2) = (1.0d0/9.0d0)*sqrt(x*x + sin(z) + 1.06d0) + 0.9d0 + fdata(3) = -(1/20.d0)*exp(-x*(y - 1.0d0)) - (10.d0*PI - 3.0d0)/60.0d0 call FN_VLinearSum(1.0d0, f, -1.0d0, y0, f) @@ -192,36 +191,36 @@ integer(C_INT) function FPFunction(ycor, f, mem) & end function - integer(C_INT) function check_ans(ycor, tol) & + integer(c_int) function check_ans(ycor, tol) & result(retval) bind(C) use, intrinsic :: iso_c_binding implicit none type(N_Vector) :: ycor - real(C_DOUBLE), value :: tol - real(C_DOUBLE) :: ex, ey, ez - real(C_DOUBLE), pointer :: data(:) + real(c_double), value :: tol + real(c_double) :: ex, ey, ez + real(c_double), pointer :: data(:) ! extract and print solution data => FN_VGetArrayPointer(ycor) - write(*,*) 'Solution:' - write(*,'(A,E14.7)') ' x = ', data(1) - write(*,'(A,E14.7)') ' y = ', data(2) - write(*,'(A,E14.7)') ' z = ', data(3) + write (*, *) 'Solution:' + write (*, '(A,E14.7)') ' x = ', data(1) + write (*, '(A,E14.7)') ' y = ', data(2) + write (*, '(A,E14.7)') ' z = ', data(3) ex = data(1) - XTRUE ey = data(2) - YTRUE ez = data(3) - ZTRUE - write(*,*) 'Solution Error:' - write(*,'(A,E14.7)') ' ex = ', ex - write(*,'(A,E14.7)') ' ey = ', ey - write(*,'(A,E14.7)') ' ez = ', ez + write (*, *) 'Solution Error:' + write (*, '(A,E14.7)') ' ex = ', ex + write (*, '(A,E14.7)') ' ey = ', ey + write (*, '(A,E14.7)') ' ez = ', ez - tol = tol * 10.0d0 + tol = tol*10.0d0 if (ex > tol .or. ey > tol .or. ez > tol) then - retval = 1 + retval = 1 end if retval = 0 @@ -238,10 +237,10 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: fails = 0 + integer(c_int) :: fails = 0 !============== Introduction ============= - write(*,*) 'SUNNonlinearSolver_FixedPoint Fortran 2003 interface test' + write (*, *) 'SUNNonlinearSolver_FixedPoint Fortran 2003 interface test' call Test_Init(SUN_COMM_NULL) @@ -250,7 +249,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/sunnonlinsol/newton/test_fsunnonlinsol_newton_mod.f90 b/examples/sunnonlinsol/newton/test_fsunnonlinsol_newton_mod.f90 index 9308fa902f..9c85724f72 100644 --- a/examples/sunnonlinsol/newton/test_fsunnonlinsol_newton_mod.f90 +++ b/examples/sunnonlinsol/newton/test_fsunnonlinsol_newton_mod.f90 @@ -22,13 +22,13 @@ module test_fsunnonlinsol_newton implicit none integer(kind=myindextype), parameter :: NEQ = 3 ! number of equations - integer(C_INT), parameter :: MAXIT = 10 ! max nonlinear iters. - real(C_DOUBLE), parameter :: TOL = 1.0e-2 ! nonlinear solver tolerance + integer(c_int), parameter :: MAXIT = 10 ! max nonlinear iters. + real(c_double), parameter :: TOL = 1.0e-2 ! nonlinear solver tolerance ! approximate solution - real(C_DOUBLE) :: Y1 = 0.785196933062355226 - real(C_DOUBLE) :: Y2 = 0.496611392944656396 - real(C_DOUBLE) :: Y3 = 0.369922830745872357 + real(c_double) :: Y1 = 0.785196933062355226 + real(c_double) :: Y2 = 0.496611392944656396 + real(c_double) :: Y3 = 0.369922830745872357 type, private :: IntegratorMem type(N_Vector), pointer :: y0 @@ -42,7 +42,7 @@ module test_fsunnonlinsol_newton contains - integer(C_INT) function unit_tests() result(retval) + integer(c_int) function unit_tests() result(retval) use, intrinsic :: iso_c_binding use fsundials_core_mod use fnvector_serial_mod @@ -53,22 +53,22 @@ integer(C_INT) function unit_tests() result(retval) implicit none type(SUNNonlinearSolver), pointer :: NLS ! test nonlinear solver - real(C_DOUBLE), pointer :: ydata(:) - integer(C_LONG) :: niters(1) - integer(C_INT) :: tmp - type(IntegratorMem), pointer :: Imem + real(c_double), pointer :: ydata(:) + integer(c_long) :: niters(1) + integer(c_int) :: tmp + type(IntegratorMem), pointer :: Imem retval = 0 ! create mock integrator memory - allocate(Imem) + allocate (Imem) ! create vectors - Imem%y0 => FN_VNew_Serial(NEQ, sunctx) + Imem%y0 => FN_VNew_Serial(NEQ, sunctx) Imem%ycur => FN_VClone(Imem%y0) Imem%ycor => FN_VClone(Imem%y0) - Imem%w => FN_VClone(Imem%y0) - Imem%x => FN_VClone(Imem%y0) + Imem%w => FN_VClone(Imem%y0) + Imem%x => FN_VClone(Imem%y0) ! set initial guess for the state call FN_VConst(HALF, Imem%y0) @@ -80,12 +80,12 @@ integer(C_INT) function unit_tests() result(retval) call FN_VConst(ONE, Imem%w) ! create matrix and linear solver - Imem%A => FSUNDenseMatrix(NEQ, NEQ, sunctx) + Imem%A => FSUNDenseMatrix(NEQ, NEQ, sunctx) Imem%LS => FSUNLinSol_Dense(Imem%y0, Imem%A, sunctx) retval = FSUNLinSolInitialize(Imem%LS) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNLinSolInitialize returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNLinSolInitialize returned ', retval return end if @@ -94,38 +94,38 @@ integer(C_INT) function unit_tests() result(retval) retval = FSUNNonlinSolSetSysFn(NLS, c_funloc(Res)) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetSysFn returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetSysFn returned ', retval return end if retval = FSUNNonlinSolSetLSetupFn(NLS, c_funloc(LSetup)) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetLSetupFn returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetLSetupFn returned ', retval return end if retval = FSUNNonlinSolSetLSolveFn(NLS, c_funloc(LSolve)) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetLSolveFn returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetLSolveFn returned ', retval return end if retval = FSUNNonlinSolSetConvTestFn(NLS, c_funloc(ConvTest), c_null_ptr) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetConvTestFn returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetConvTestFn returned ', retval return end if retval = FSUNNonlinSolSetMaxIters(NLS, MAXIT) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSetMaxIters returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSetMaxIters returned ', retval return end if retval = FSUNNonlinSolSolve(NLS, Imem%y0, Imem%ycor, Imem%w, TOL, 1, & c_loc(Imem)) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolSolve returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolSolve returned ', retval return end if @@ -135,23 +135,23 @@ integer(C_INT) function unit_tests() result(retval) ! extract solution data ydata => FN_VGetArrayPointer(Imem%ycur) - write(*,*) 'Solution:' - write(*,'(A,E14.7)') 'y1 = ', ydata(1) - write(*,'(A,E14.7)') 'y2 = ', ydata(2) - write(*,'(A,E14.7)') 'y3 = ', ydata(3) + write (*, *) 'Solution:' + write (*, '(A,E14.7)') 'y1 = ', ydata(1) + write (*, '(A,E14.7)') 'y2 = ', ydata(2) + write (*, '(A,E14.7)') 'y3 = ', ydata(3) - write(*,*) 'Solution Error:' - write(*,'(A,E14.7)') 'e1 = ', ydata(1) - Y1 - write(*,'(A,E14.7)') 'e2 = ', ydata(2) - Y2 - write(*,'(A,E14.7)') 'e3 = ', ydata(3) - Y3 + write (*, *) 'Solution Error:' + write (*, '(A,E14.7)') 'e1 = ', ydata(1) - Y1 + write (*, '(A,E14.7)') 'e2 = ', ydata(2) - Y2 + write (*, '(A,E14.7)') 'e3 = ', ydata(3) - Y3 retval = FSUNNonlinSolGetNumIters(NLS, niters) if (retval /= 0) then - write(*,'(A,I0)') ' >>> FAIL: FSUNNonlinSolGetNumIters returned ', retval + write (*, '(A,I0)') ' >>> FAIL: FSUNNonlinSolGetNumIters returned ', retval return end if - write(*,'(A,I0)') 'Number of nonlinear iterations:', niters(1) + write (*, '(A,I0)') 'Number of nonlinear iterations:', niters(1) ! cleanup call FN_VDestroy(Imem%y0) @@ -162,26 +162,24 @@ integer(C_INT) function unit_tests() result(retval) call FSUNMatDestroy(Imem%A) tmp = FSUNLinSolFree(Imem%LS) tmp = FSUNNonlinSolFree(NLS) - deallocate(Imem) + deallocate (Imem) end function unit_tests - integer(C_INT) function LSetup(jbad, jcur, mem) & + integer(c_int) function LSetup(jbad, jcur, mem) & result(retval) bind(C) use, intrinsic :: iso_c_binding - - implicit none type(N_Vector), pointer :: fy, tmp1, tmp2, tmp3 - integer(C_INT), value :: jbad - integer(C_INT), dimension(*) :: jcur - type(C_PTR), value :: mem + integer(c_int), value :: jbad + integer(c_int), dimension(*) :: jcur + type(c_ptr), value :: mem type(IntegratorMem), pointer :: Imem ! set unused parameters to null() - fy => null() + fy => null() tmp1 => null() tmp2 => null() tmp3 => null() @@ -190,7 +188,7 @@ integer(C_INT) function LSetup(jbad, jcur, mem) & call c_f_pointer(mem, Imem) ! compute the Jacobian - retval = Jac(0.d0, Imem%ycur, fy, Imem%A, C_NULL_PTR, tmp1, tmp2, tmp3) + retval = Jac(0.d0, Imem%ycur, fy, Imem%A, c_null_ptr, tmp1, tmp2, tmp3) if (retval /= 0) return ! update Jacobian status @@ -200,16 +198,14 @@ integer(C_INT) function LSetup(jbad, jcur, mem) & end function - integer(C_INT) function LSolve(b, mem) & + integer(c_int) function LSolve(b, mem) & result(retval) bind(C) use, intrinsic :: iso_c_binding - - implicit none type(N_Vector) :: b - type(C_PTR), value :: mem + type(c_ptr), value :: mem type(IntegratorMem), pointer :: Imem ! get the Integrator memory Fortran type out @@ -220,19 +216,17 @@ integer(C_INT) function LSolve(b, mem) & end function - integer(C_INT) function ConvTest(NLS, y, del, tol, ewt, mem) & + integer(c_int) function ConvTest(NLS, y, del, tol, ewt, mem) & result(retval) bind(C) use, intrinsic :: iso_c_binding - - implicit none type(SUNNonlinearSolver) :: NLS type(N_Vector) :: y, del, ewt - real(C_DOUBLE), value :: tol - type(C_PTR), value :: mem - real(C_DOUBLE) :: delnrm + real(c_double), value :: tol + type(c_ptr), value :: mem + real(c_double) :: delnrm ! compute the norm of the correction delnrm = FN_VWrmsNorm(del, ewt) @@ -245,17 +239,16 @@ integer(C_INT) function ConvTest(NLS, y, del, tol, ewt, mem) & end function - integer(C_INT) function Res(ycor, f, mem) & + integer(c_int) function Res(ycor, f, mem) & result(retval) bind(C) use, intrinsic :: iso_c_binding - implicit none type(N_Vector) :: ycor, f - type(C_PTR), value :: mem - real(C_DOUBLE), pointer :: ydata(:), fdata(:) - real(C_DOUBLE) :: y1, y2, y3 + type(c_ptr), value :: mem + real(c_double), pointer :: ydata(:), fdata(:) + real(c_double) :: y1, y2, y3 type(IntegratorMem), pointer :: Imem ! get the Integrator memory Fortran type out @@ -272,28 +265,27 @@ integer(C_INT) function Res(ycor, f, mem) & y3 = ydata(3) fdata(1) = y1*y1 + y2*y2 + y3*y3 - 1.0d0 - fdata(2) = 2.0d0 * y1*y1 + y2*y2 - 4.0d0 * y3 - fdata(3) = 3 * y1*y1 - 4.0d0 * y2 + y3*y3 + fdata(2) = 2.0d0*y1*y1 + y2*y2 - 4.0d0*y3 + fdata(3) = 3*y1*y1 - 4.0d0*y2 + y3*y3 retval = 0 end function - integer(C_INT) function Jac(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & + integer(c_int) function Jac(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & result(retval) bind(C) use, intrinsic :: iso_c_binding - use fsunmatrix_dense_mod implicit none - real(C_DOUBLE), value :: t + real(c_double), value :: t type(N_Vector) :: y, fy, tmp1, tmp2, tmp3 type(SUNMatrix) :: J - type(C_PTR), value :: user_data - real(C_DOUBLE), pointer :: ydata(:), Jdata(:) - real(C_DOUBLE) :: y1, y2, y3 + type(c_ptr), value :: user_data + real(c_double), pointer :: ydata(:), Jdata(:) + real(c_double) :: y1, y2, y3 ydata => FN_VGetArrayPointer(y) Jdata => FSUNDenseMatrix_Data(J) @@ -303,9 +295,9 @@ integer(C_INT) function Jac(t, y, fy, J, user_data, tmp1, tmp2, tmp3) & y3 = ydata(3) ! dense matrix has column-major ordering - Jdata(1:9) = [ TWO*y1, FOUR*y1, SIX*y1, & - TWO*y2, TWO*y2, -FOUR, & - TWO*y3, -FOUR, TWO*y3 ] + Jdata(1:9) = [TWO*y1, FOUR*y1, SIX*y1, & + TWO*y2, TWO*y2, -FOUR, & + TWO*y3, -FOUR, TWO*y3] retval = 0 @@ -322,7 +314,7 @@ program main !======== Declarations ======== implicit none - integer(C_INT) :: retval = 0 + integer(c_int) :: retval = 0 !============== Introduction ============= print *, 'Newton SUNNonlinearSolver Fortran 2003 interface test' @@ -334,7 +326,7 @@ program main print *, 'FAILURE: n unit tests failed' stop 1 else - print *,'SUCCESS: all unit tests passed' + print *, 'SUCCESS: all unit tests passed' end if call Test_Finalize() diff --git a/examples/utilities/test_utilities.f90 b/examples/utilities/test_utilities.f90 index dc5abe7587..54c439dee3 100644 --- a/examples/utilities/test_utilities.f90 +++ b/examples/utilities/test_utilities.f90 @@ -16,42 +16,42 @@ module test_utilities - use, intrinsic :: iso_c_binding - use fsundials_core_mod - implicit none - - ! Since SUNDIALS can be compiled with 32-bit or 64-bit sunindextype - ! we set the integer kind used for indices in this example based - ! on the the index size SUNDIALS was compiled with so that it works - ! in both configurations. This is not a requirement for user codes. + use, intrinsic :: iso_c_binding + use fsundials_core_mod + implicit none + + ! Since SUNDIALS can be compiled with 32-bit or 64-bit sunindextype + ! we set the integer kind used for indices in this example based + ! on the the index size SUNDIALS was compiled with so that it works + ! in both configurations. This is not a requirement for user codes. #if defined(SUNDIALS_INT32_T) - integer, parameter :: myindextype = selected_int_kind(8) + integer, parameter :: myindextype = selected_int_kind(8) #elif defined(SUNDIALS_INT64_T) - integer, parameter :: myindextype = selected_int_kind(16) + integer, parameter :: myindextype = selected_int_kind(16) #endif - real(C_DOUBLE), parameter :: SUN_UNIT_ROUNDOFF = epsilon(1.0d0) + real(c_double), parameter :: SUN_UNIT_ROUNDOFF = epsilon(1.0d0) - real(C_DOUBLE) :: NEG_TWO = -2.0d0 - real(C_DOUBLE) :: NEG_ONE = -1.0d0 - real(C_DOUBLE) :: NEG_HALF = -0.50d0 - real(C_DOUBLE) :: ZERO = 0.0d0 - real(C_DOUBLE) :: HALF = 0.5d0 - real(C_DOUBLE) :: ONE = 1.0d0 - real(C_DOUBLE) :: TWO = 2.0d0 - real(C_DOUBLE) :: THREE = 3.0d0 - real(C_DOUBLE) :: FOUR = 4.0d0 - real(C_DOUBLE) :: FIVE = 5.0d0 - real(C_DOUBLE) :: SIX = 6.0d0 + real(c_double) :: NEG_TWO = -2.0d0 + real(c_double) :: NEG_ONE = -1.0d0 + real(c_double) :: NEG_HALF = -0.50d0 + real(c_double) :: ZERO = 0.0d0 + real(c_double) :: HALF = 0.5d0 + real(c_double) :: ONE = 1.0d0 + real(c_double) :: TWO = 2.0d0 + real(c_double) :: THREE = 3.0d0 + real(c_double) :: FOUR = 4.0d0 + real(c_double) :: FIVE = 5.0d0 + real(c_double) :: SIX = 6.0d0 - type(C_PTR) :: sunctx + type(c_ptr) :: sunctx contains subroutine Test_Init(comm) implicit none - integer(C_INT), value :: comm - integer(C_INT) :: retval + integer(c_int), value :: comm + integer(c_int) :: retval retval = FSUNContext_Create(comm, sunctx) if (retval /= 0) then @@ -63,19 +63,19 @@ subroutine Test_Init(comm) subroutine Test_Finalize() implicit none - integer(C_INT) :: retval + integer(c_int) :: retval retval = FSUNContext_Free(sunctx) end subroutine - integer(C_INT) function FNEQTOL(a, b, tol) result(nequal) + integer(c_int) function FNEQTOL(a, b, tol) result(nequal) implicit none - real(C_DOUBLE) :: a, b, tol + real(c_double) :: a, b, tol if (a /= a) then nequal = 1 - else if ((abs(a-b)/abs(b)) > tol) then + else if ((abs(a - b)/abs(b)) > tol) then nequal = 1 else nequal = 0 @@ -83,13 +83,13 @@ integer(C_INT) function FNEQTOL(a, b, tol) result(nequal) end function FNEQTOL - integer(C_INT) function FNEQ(a, b) result(nequal) + integer(c_int) function FNEQ(a, b) result(nequal) implicit none - real(C_DOUBLE) :: a, b + real(c_double) :: a, b if (a /= a) then nequal = 1 - else if ((abs(a-b)/abs(b)) > (10*SUN_UNIT_ROUNDOFF)) then + else if ((abs(a - b)/abs(b)) > (10*SUN_UNIT_ROUNDOFF)) then nequal = 1 else nequal = 0 diff --git a/scripts/format.sh b/scripts/format.sh index 21dc930698..b145adcfad 100755 --- a/scripts/format.sh +++ b/scripts/format.sh @@ -10,7 +10,8 @@ # SPDX-License-Identifier: BSD-3-Clause # SUNDIALS Copyright End # --------------------------------------------------------------------------------- -# This script will use clang-tidy and clang-format to format code. +# This script will use clang-tidy and clang-format to format C/C++ code and +# fprettify for Fortran code. # # Usage: # ./format.sh @@ -28,3 +29,5 @@ paths=( "$@" ) find "${paths[@]}" -iname '*.h' -o -iname '*.hpp' -o \ -iname '*.c' -o -iname '*.cpp' -o \ -iname '*.cuh' -o -iname '*.cu' | grep -v fmod | xargs clang-format -i + +find "${paths[@]}" -iname '*.f90' | grep -v fmod | xargs fprettify --indent 2 --enable-replacements --c-relations diff --git a/test/unit_tests/arkode/F2003_serial/ark_test_table_f2003.f90 b/test/unit_tests/arkode/F2003_serial/ark_test_table_f2003.f90 index 55ef49d612..ab06dfa929 100644 --- a/test/unit_tests/arkode/F2003_serial/ark_test_table_f2003.f90 +++ b/test/unit_tests/arkode/F2003_serial/ark_test_table_f2003.f90 @@ -25,7 +25,7 @@ program main implicit none type(c_ptr) :: table ! Butcher table object - character (len=19) :: table_name ! table name + character(len=19) :: table_name ! table name integer(c_int) :: ierr ! error flag integer(c_int) :: q(1) ! table order integer(c_int) :: p(1) ! table embedded order @@ -33,14 +33,14 @@ program main print *, 'Loading ARKODE_DORMAND_PRINCE_7_4_5' table = FARKodeButcherTable_LoadERKByName('ARKODE_DORMAND_PRINCE_7_4_5') if (.not. c_associated(table)) then - write(error_unit,*) 'FARKodeButcherTable_LoadERKByName returned NULL' + write (error_unit, *) 'FARKodeButcherTable_LoadERKByName returned NULL' stop 1 end if print *, 'Checking ARKODE_DORMAND_PRINCE_7_4_5 order' - ierr = FARKodeButcherTable_CheckOrder(table, q, p, c_null_ptr); + ierr = FARKodeButcherTable_CheckOrder(table, q, p, c_null_ptr); if (ierr /= 0) then - write(error_unit, *) 'FARKodeButcherTable_CheckOrder returned ', ierr + write (error_unit, *) 'FARKodeButcherTable_CheckOrder returned ', ierr stop 1 end if @@ -50,14 +50,14 @@ program main table_name = 'ARKODE_TRBDF2_3_3_2' table = FARKodeButcherTable_LoadDIRKByName(table_name) if (.not. c_associated(table)) then - write(error_unit,*) 'FARKodeButcherTable_LoadDIRKByName returned NULL' + write (error_unit, *) 'FARKodeButcherTable_LoadDIRKByName returned NULL' stop 1 end if print *, 'Checking ARKODE_TRBDF2_3_3_2 order' - ierr = FARKodeButcherTable_CheckOrder(table, q, p, c_null_ptr); + ierr = FARKodeButcherTable_CheckOrder(table, q, p, c_null_ptr); if (ierr /= 0) then - write(error_unit, *) 'FARKodeButcherTable_CheckOrder returned ', ierr + write (error_unit, *) 'FARKodeButcherTable_CheckOrder returned ', ierr stop 1 end if @@ -66,14 +66,14 @@ program main print *, 'Loading ARKODE_DIRK_NONE' table = FARKodeButcherTable_LoadDIRKByName('ARKODE_DIRK_NONE') if (c_associated(table)) then - write(error_unit, *) 'FARKodeButcherTable_LoadDIRKByName returned non-NULL for ARKODE_DIRK_NONE' + write (error_unit, *) 'FARKodeButcherTable_LoadDIRKByName returned non-NULL for ARKODE_DIRK_NONE' stop 1 end if print *, 'Loading invalid table. This should print an error' table = FARKodeButcherTable_LoadERKByName('does not exist') if (c_associated(table)) then - write(error_unit, *) 'FARKodeButcherTable_LoadERKByName returned non-NULL for invalid table name' + write (error_unit, *) 'FARKodeButcherTable_LoadERKByName returned non-NULL for invalid table name' stop 1 end if