!*********************************************************************** ! ! Copyright (c) 2015, Lawrence Livermore National Security, LLC. ! Produced at the Lawrence Livermore National ! Laboratory. ! Written by Nicolas Schunck, schunck1@llnl.gov ! ! LLNL-CODE-573953 All rights reserved. ! ! Copyright 2012, M.V. Stoitsov, N. Schunck, M. Kortelainen, H.A. Nam, ! N. Michel, J. Sarich, S. Wild ! Copyright 2005, M.V. Stoitsov, J. Dobaczewski, W. Nazarewicz, P.Ring ! ! This file is part of HFBTHO. ! ! HFBTHO is free software: you can redistribute it and/or modify it ! under the terms of the GNU General Public License as published by ! the Free Software Foundation, either version 3 of the License, or ! (at your option) any later version. ! ! HFBTHO is distributed in the hope that it will be useful, but ! WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with HFBTHO. If not, see . ! ! OUR NOTICE AND TERMS AND CONDITIONS OF THE GNU GENERAL PUBLIC ! LICENSE ! ! Our Preamble Notice ! ! A. This notice is required to be provided under our contract ! with the U.S. Department of Energy (DOE). This work was ! produced at the Lawrence Livermore National Laboratory under ! Contract No. DE-AC52-07NA27344 with the DOE. ! B. Neither the United States Government nor Lawrence Livermore ! National Security, LLC nor any of their employees, makes any ! warranty, express or implied, or assumes any liability or ! responsibility for the accuracy, completeness, or usefulness ! of any information, apparatus, product, or process disclosed, ! or represents that its use would not infringe privately-owned ! rights. ! C. Also, reference herein to any specific commercial products, ! process, or services by trade name, trademark, manufacturer ! or otherwise does not necessarily constitute or imply its ! endorsement, recommendation, or favoring by the United States ! Government or Lawrence Livermore National Security, LLC. The ! views and opinions of authors expressed herein do not ! necessarily state or reflect those of the United States ! Government or Lawrence Livermore National Security, LLC, and ! shall not be used for advertising or product endorsement ! purposes. ! ! The precise terms and conditions for copying, distribution and ! modification are contained in the file COPYING. ! !*********************************************************************** !================================================================================================================================== !#START HFBTHO_VERSION MODULE !================================================================================================================================== Module HFBTHO_VERSION Implicit None Character(6) :: Version='200i' !-------------------------------------------------------------------------------------- ! Version History !-------------------------------------------------------------------------------------- ! ver#200e: added preprocessor option SWITCH_ESSL to use IBM libraries ! ver#200d: fixed bug in gfv; improved legibility and accuracy of coulom and coulom1 ! ver#200c: added LLNL release number ! ver#200b: added module linear_algebra, analyzing THO, formatted output, fixed bug ! in calculation of entropy ! ver#200a: Restored option to compute all blocking configurations within given energy ! window, removed spurious output printing ! ver#199: added a few input options and a compatibility mode with HFODD. Release ! candidate before publication, last bug to fix is OpenMP in hfbdiag() ! ver#142: removed module pairing, module UNEDF, spurious preprocessing options ! for publication purposes; used the Lahey compiler to identify a few bugs, ! added routine check_consistency(), module HFBTHO_gauss, improved file ! handling in inout() and fixed bug in multipole moments ! ver#141: Reinstated the THO module ! ver#140: added a namelist for debugging purposes, added OpenMP in coulom() ! ver#139a: fixed bug in readjustment of constraint at finite T, cleaned up output ! system, fixed bug in calculation of Coulomb in parity breaking mode ! ver#139: added temperature ! ver#138: added new module HFBTHO_utilities to improve portability ! ver#137: new system of inputs based on several namelists contained in one unique ! file called hfbtho_NAMELIST.dat, multiple constraints up and running ! ver#136: ANL OpenMP optimizations included, and code clean-up ! ver#135: Tested with all previous versions of HFBTHO down to 101, full compatibility ! achieved ! ver#134: Begining of work toward publication ! ver#133: Single-file HFBTHO ! ver#130: tho.dat mdifications due to blocking, error indicator introduced ! ver#129: Even-even tested and equivalent with ptho101spt15sp.f90 used in ANL fit ! ver#128: EQP,U,V and their dimentions NUV,NEQ required for qrpa incoporated ! permanently in HFBTHO substituting old arrays eqp and uv ! ver#127: For easy development the module split in different F90 files which are ! invoked using INCLUDE statements (remove that when developement is over) ! Optimized qrpa_DENSIT_PLUS and qrpa_GAMDEL to be twice faster ! ver#126: Cleaning, optimizing, and isolating THO stuff ! parity good: Time per iteration: 3.841 seconds ! parity broken: Time per iteration: 9.933 seconds ! HFB+THO tested and works in both parity regimes. iserial removed and ! substituted with Print_Screen, i.e, record results only when Nsh>0 ! ver#125: Implemented and tested reflection symmetry as option. If parity is broken, ! computer time per iteration is almost 5 times bigger: ! parity good: Time per iteration: 4.5276 seconds ! parity broken: Time per iteration: 19.4646 seconds ! difference in total energy: 0.001 keV ! ver#124: Rewrite to prepare for breaking reflection symmetry ! Preprocessing directives included: #ifndef hide_qrpa, hide_tho, hide_dme ! For preprocessing one needs -Dhide_qrpa -Dhide_tho -Dhide_dme ! If no preprocessing or -Uhide_qrpa -Uhide_tho -Uhide_dme then ! all modules are included ! ver#123: Playground for QRPA calculations [16/12/2010]: ! The changes are: ! - all variables in Module HFBTHO are Public ! - include_qrpa=0 is added to Module HFBTHO with asssociated ! declarations eventualy used by qrpa ! - Subroutine ByNucleus moved to PTHO_PROGRAM where is its place ! and it should be done long ago. Call Do_QRPA() is used only there. ! - So if the program is compiled with -Uhide_qrpa one can use Do_QRPA() ! to do qrpa calculations. ! ver#123: Fixed crash after iterations limit. ! Tested against anl version hfbtho101spt15.f90 - itterations go differently ! but the final results are identical. ! ver#122: (MK) Added CExPar for coulomb exchange. Parameter read from UNEDF module ! ver#121: (MK) Added possibility to use zero particle number for droplet calculations ! ver#120: (MK) Added external field, and all channels to direct Hartree. e^2 for Coulomb ! now read from the UNEDF module. Direct Hartree now always calculated based on ! module function regardless of the value of DMEorder parameter ! ver#117: Direct Hartree added when DME_order>-1 ! ver#115: (MK) added use_cm_cor variable to hb0 calculation and (nabla rho)^2 terms to ! the calculate_U_parameters function calls ! ver#114: Name list, new tho.dat file, proton/neutron fields, confirms all results of ! recent published version after ANL optimization ptho101b_last_tested.f90, ! public/Public variables ! ver#113: Cleaning ! ver#112: No parameter functions ! ver#111: Main program detached from the file as PTHO_MAIN_PROGRAM.f90 which will not be ! versioned. ptho becomes jus a HFBTHO module. Pairing constants V0(2),V1(2) ! replaced by CpV0(0:1), CpV1(0:1) coming as public from defined in UNEDF module ! Removed dalf and ippforce form the pairing. For compatibility, ippforce ! stays in the input file by now but the kind of pairing is given by CpV1 only ! Dropped corrections 'ecmcpavpj', 'erotcorrection' which should be added later. ! For compatibility inputfile stays the same. Added IDEUB. ! THO part in 'densit' (not densitpj), 'gamdel' commented HO/THO for speed ! ver#109: All public variables, expectpj works with a jump: not clear how UNEDF can work ! with complex numbers, just skip this part by now bu write results data ! New thodefh(iw1) ! ver#108: Removed all programs not used in ver#107 ! expect contains a key DO_FITT: ! =0 calculare energy, delta, def & rms only ! =1 the same+all integrals for the regression optimization ! V0,V1 pairing constant separated for neutrons and protons: v0(2),v1(2) ! HFBTHO collected in MODULE HFBTHO ! KOP3 removed ! ver#107: Towards UNEDF: complete rewrite based on Marcus to include N2LO ! LN for ZR110 at prolate solution with SLY4, mixed pairing and tensor terms: ! -agreement with previouse Skyrme implemetation to the last significant digit ! -agreement with previouse LO+LDA implemetation to the last significant digit ! -agreement with previouse LO+CB implemetation to the last significant digit ! ver#106: Towards UNEDF: the standard functional rewritten in terms of UNEDF U-amplitudes ! The assumption U=U(tau_0,Delta rho_0,rho_0,rho_1) becomes possible after ! adding Nabla rho_ij terms (STANDARD FUNCTIONAL ONLY) ! ver#105: Towards UNEDF: the standard functional rewritten in terns of UNEDF U-amplitudes ! The assumption U=U(rho_0,rho_1) becomes possible after adding Delta rho_ij terms ! ver#104: Broyden improved with linear search at negative curvature ! Implemented Agumented Lagrangian method for constraint calculations ! Manual blocking included and tested, key: manualBlocking ! ver#103: From this version on-no more support for VAP (VAP completely removed) ! The whole program in terms of C-parameters (including tenzor terms) ! ver#102: The whole program in terms of C-parameters (without tenzor terms) ! ver#101: Optimization in terms of nuclear matter: 'FITS' regime ! ver#100: Toward isovector pairing following Sagawa and Yamagami ! ver# 99: Subroutine HFBiterations. The isotopic line in tho.dat removed. ! Subroutines byNucleus, byConstraint, FitPairing, HFBTHO_HFODD isolated ! at the end and could be ported if necessary. skyrme='FITS' assumes the skyrme ! parameters as explicitely given. -N00 supresses completely the output and only ! hodef.dat and thodef.dat are charged (if iserial=0 even these files are supressed) ! HFBTHO_HFODD updated (think further about a constraint in Q2 terms) ! ver# 98: INOUT modified and added interface subroutine HFBTHO_HFODD ! Pairing fitted with MIX/(LN-NOLN) for SLY4,SKP,SKM* forces ! ver# 97: Corrected blocking candidates criteria ! ver# 96: Extended so term W0,W1 and SKLY4T forces ! ver# 95: Pairing regularization removed, linear HFBDIAG mixing for Lambda ! when blocking, DSYEV replaced by the faster DSYEVD, hfbdiag caculates ! canonical basis only at the last hfbdiag iteration, expect optimized ! new subroutines HFBiterations, FitPairing, byConstraint ! Work around a bug in LAPAK related to DSYEVD ! ver# 94: Misprints ! ver# 93: Removed hh and de matrices and related manipulations ! Broyden_min now escape maximum and inflex points ! ver# 92: Bug in blocking while no pairing cleaned ! ver# 91: BLAST & LAPACK diagonalization ! ver# 90: If applying Broyden method to matrix elements then ! at 20 shells the total number of matrix elements ! is 2x2x65307=261228 or about 2.1 Mb and if one keeps ! 8 iterations it will be about 17 Mb-not too much ! This is the only way one can mix Lipkin-Nogami ! ! If one uses the potentials at 30x30 grid points ! the numbers are 8x2x900=14400 or 115 Kb and if one keeps ! 8 iterations it will be about 1 Mb-much better ! but Lipkin-Nogami is out of this scheme (?!) ! If one uses densities at 30x30 grid points they ! are 9x2x900-almost like the potential case. ! (sent to George) ! ver# 89: Reduced printout (no anymore lprinter) ! LN del+ala2 printed during the iterations ! Strength in the initial constraint calculations reduced to 0.3, requested ! deformation+/-0.3, untill si<1.1 ! If too slow convergence (1000 iterations) and Lambda>0 interrupt iterations ! Odd nucleus right away from the even-even (even) solution ! When even solution missing/corrupt (even at inin<0) calculate it first ! and then odd one ! ver# 88: Synchronization for the parallel run ! FileLabel subroutine added. ! Modified inin control ! inin<0: Always start from a file if it exists, not corrupted and correct ! otherwise inin=iabs(inin) and start from scratch ! inin>0: Always start from scratch ! SCRATCH calculations start with initial 20 constrained iteration if constrain ! is not requested (icstr=0). When icstr#0 standard constraint calculations. ! BY CHAIN calculations temporary removed due to blocking complications ! ver# 87: Approximate Blocking keeping time-reversal symmetry to PNP PAV ! ver# 86: Approximate Blocking keeping time-reversal symmetry and tested agings HFODD ! ver# 85: LN in canonical basis. Benchmark to HFODD ! ver# 84: Testing HFODD LN again HFB-HO ! ver# 83: Cleaning, SKM* mixed volume LN pairing fitted ! ver# 82: As 81 but prepared for jaguar ! ver# 81: Pairing regularization/renormalization. PAV done with unprojected v_k ! V0(Nsh=20,pwi=50) fitted for SLY4,SKP,Renormalized,Regularized,Mixed,Volume ! Removed delta and gamdel0 completely ! ver# 80: Accuracy for large number of shells increased by the number of gauss points ! Gaussian points now calculated ! Initial guest now from deformed Wood-Saxon ! Initial run now starts with requested shell number n00 ! ver# 79: Cranking rotational correction implemented: ! Printed to screen, thoout.dat, hodef.dat and thodef.dat ! but not added to the energy ! ver# 78: Full CM correction implemented in HFB & HFB(PAV) ! Printed to screen, thoout.dat, hodef.dat and thodef.dat ! but not added to the energy ! NB : ilpjnp(2) removed ! ver# 77: Automated Blocking: ! First is calculated N,Z without blocking, remembered *.hel *.tel files and ! determined blocking candidates according to pwablo criteria. ! if N(Z) is odd we have neutron(proton) blocking candidates. ! if both, N and Z, are odd we have both, neutron and proton, block.candidates ! Then we block state after state among the blocking candidates and calculate ! starting from the recorded unblocked (N,Z) solution ! if only N ( or Z) is odd then all neutron (or proton) blocking candidates ! are calculated ! if both N and Z are odd all pairs of proton and neutron blocking candidates ! are calculated (PAV &LN unclear) ! ver# 76: Manual Blocking for a particular state in a particular block ! overlap criteria used to avoid the level crossing problem (PAV &LN unclear) ! ver# 75: Manual Blocking for the minimal qpe within a given block. ! ver# 74: Bulgac procedure .. not done ! ver# 73: Cleanup, introducing the cpc notations, beyond unit circle removed (MARK 1) ! ver# 72: PNP: still valid version for integration over the unit circle ! ver# 71: PNP: towards beyond unit circle integration ! ver# 70: PNP: detached neutron from proton projection ! ver# 69: PNP: quadrupole constraint fixed to converge ! ver# 68: equivalent to var#67 ! ver# 67: PNP: corrections to the tensor term and initial dumping factor ! ver# 66: PNP: V0 fitted to PLN energies at Sn126 for SKP mixed and volume at Nsh=20,HO ! ver# 65: deformed HO basis implemented and tested ! ver# 64: fixed byChain to go not 2 beyond the forced break ! ver# 63: iasswrong(3) fixed for correct multiprocessor run ! ver# 61/62: pthotop for Cheetah added at the end ! ver# 60: Thodef.dat header line fixed (added U:). Fixed P/N in ByChain calculations ! The 'Stop' is removed from mishmatch conditions with alternative to use old one. ! Consistent pairing for SLY4 and SKP forces ! ver# 59: LST modified to accept negative aa-values. SLY4 And SKP with consistent ! (high densities regime) pairing for all cases. Old asymptotic prescription ! is used in the case of Mishmatch asymptotic. Temporary,still new SLY4 ! pairing constants are commented. ! ver# 58: Proton line in byChain ! calculations goes vertically. In case of wrong ! asymptotic parameter 'kindhfb' is recorded as 'kindhfb+100' in thodef.dat ! file where the results for this nucleus are substituted with HO results ! Only Nsh=20 pairing constants are already fitted to the higher density ! asymptotic prescription which is already enforced. (Temporary, still old ! SLY4 pairing constants are in the code). ! ver# 57: Partially refitted pairing constants according to the new asymptotic ! prescription. NB! old constants are still for the SLY4 force and not all of ! the cases with SKP are fitted. Old ass. regime is temporary enforced. ! ver# 56: Code optimization and checks ! ver# 55: Tensor term J.J implemented and tested ! ver# 54: Back to *.hel *.tel files; Including new hodef.dat like thodef.dat file ! ver# 53: LST is choosing the higher density in the asymptotic region !-------------------------------------------------------------------------------------- End Module HFBTHO_VERSION !================================================================================================================================== !#END HFBTHO_VERSION MODULE !================================================================================================================================== !#START HFBTHO_utilities !================================================================================================================================== Module HFBTHO_utilities Implicit None Integer, Parameter, Public :: ipr=Kind(1) ! to set the precision of the DFT solver Integer, Parameter, Public :: pr =Kind(1.0) ! to set the precision of the DFT solver ! I/O Integer, Public :: lout = 6, lfile = 7 ! Global numbers Real(pr), Parameter :: zero=0.0_pr,half= 0.5_pr,one=1.0_pr,two =2.0_pr,three=3.0_pr, & four=4.0_pr,five= 5.0_pr,six=6.0_pr,seven=7.0_pr,eight=8.0_pr, & nine=9.0_pr,ten =10.0_pr ! Whole global numbers pp# Real(pr), Parameter :: pp12=12.0_pr,pp16=16.0_pr,pp15=15.0_pr,pp20=20.0_pr, & pp24=24.0_pr,pp27=27.0_pr,pp32=32.0_pr,pp64=64.0_pr, & pp40=40.0_pr ! Fractional global numbers p# Real(pr), Parameter :: p12=one/two, p13=one/three, p14=one/four, p23=two/three, & p43=four/three,p32=three/two, p34=three/four,p53=five/three,& p18=one/eight, p38=three/eight,p59=five/nine, p52=five/two, & p54=five/four, p74=seven/four Contains !=============================================================================================== ! !=============================================================================================== Subroutine get_CPU_time (subname,is) Implicit None Integer, Intent(in) :: is Character*(*), Intent(in) :: subname Real(pr), Save :: time1,time2 ! If(is.Eq.0) Then Call cpu_time(time1) Else Call cpu_time(time2) Write(lout,'(a,a,a,G16.6)') ' Time in seconds -> ',Trim(subname),':',time2-time1 End If ! End Subroutine get_CPU_time ! End Module HFBTHO_utilities !================================================================================================================================== !#END HFBTHO_utilities !================================================================================================================================== !#START linear_algebra MODULE !================================================================================================================================== Module linear_algebra Use HFBTHO_utilities Implicit None Contains !======================================================================= Subroutine lingd(ma,mx,n,m,a,x,d,Ifl) !--------------------------------------------------------------------- ! Solves the system of linear equations A*X = B ! At the beginning the matrix B is stored in X ! During the calculation it will be overwritten ! D is the determinant of A !--------------------------------------------------------------------- Integer(ipr) :: ma,mx,n,m,Ifl Integer(ipr), Save :: i,j,k,l,k1,n1 Real(pr) :: a(ma,m),x(mx,m),d Real(pr), Save :: tollim,one,zero,p,q,tol,cp,cq Data tollim/1.d-10/,one/1._pr/,zero/0._pr/ Ifl = 1; p = zero Do i=1,n q = zero Do j=1,n q = q + Abs(a(i,j)) End Do If(q.Gt.p) p = q End Do tol = tollim*p; d = one Do k=1,n p = zero Do j=k,n q = Abs(a(j,k)) If(q.Lt.p) Cycle p = q; i = j End Do If (p.Lt.tol) Then Write (6,200) ('-',j=1,80),tol,i,k,a(i,k),('-',j=1,80) 200 Format (/1x,80a1/' ***** ERROR IN LINGD , TOLERANZ =',e14.4, & ' VALUE OF A(',i3,',',i3,') IS ',e14.4/1x,80a1) Ifl = -1 Return End If cp = one/a(i,k) If(i.Ne.k) Then d = -d Do l=1,m cq = x(i,l); x(i,l) = x(k,l); x(k,l) = cq End Do Do l=k,n cq = a(i,l); a(i,l) = a(k,l); a(k,l) = cq End Do End If d = d*a(k,k) If(k.Eq.n) Exit k1 = k + 1 Do i=k1,n cq=a(i,k)*cp Do l=1,m x(i,l)=x(i,l)-cq*x(k,l) End Do Do l=k1,n a(i,l)=a(i,l)-cq*a(k,l) End Do End Do End Do Do l=1,m x(n,l)=x(n,l)*cp End Do If(n.Eq.1) Return n1=n-1 Do k=1,n1 cp = one/a(n-k,n-k) Do l=1,m cq = x(n-k,l) Do i=1,k cq = cq-a(n-k,n+1-i)*x(n+1-i,l) End Do x(n-k,l) = cq*cp End Do End Do Return End Subroutine lingd !======================================================================= ! !======================================================================= Subroutine csplin(n, x, y, b, c, d) !--------------------------------------------------------------------- ! file: csplin.for (from slac) ! The coefficients b(i), c(i), and d(i), i=1,2,...,n are computed ! for a cubic interpolating spline ! s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3 ! for x(i) <= x <= x(i+1) ! input.. ! n = the number of data points or knots (n.ge.2) ! x = the abscissas of the knots in strictly increasing order ! y = the ordinates of the knots ! output.. ! b, c, d = arrays of spline coefficients as defined above. ! using p to denote dIfferentiation, ! y(i) = s(x(i)) ! b(i) = sp(x(i)) ! c(i) = spp(x(i))/2 ! d(i) = sppp(x(i))/6 (derivative from the right) ! the accompanying function subprogram cseval can be used ! to evaluate the spline, its derivative or even its 2nd derivative. !--------------------------------------------------------------------- Integer(ipr), Save :: nm1,i,ib Integer(ipr) :: n Real(pr) :: x(n), y(n), b(n), c(n), d(n) Real(pr), Save :: t,zero=0.0_pr,two=2.0_pr,tr=3.0_pr ! check input for consistency If(n.Lt.2) Stop '-n < 2 in csplin call--' nm1 = n-1 Do i = 1, nm1 If(x(i).Ge.x(i+1)) Stop 'x not strictly ascending in csplin call' End Do If (n.Ne.2) Then ! set up tridiagonal system ! b = diagonal, d = offdiagonal, c = right hand side. d(1) = x(2) - x(1); c(2) = (y(2) - y(1))/d(1) Do i = 2, nm1 d(i) = x(i+1) - x(i); b(i) = two*(d(i-1) + d(i)) c(i+1) = (y(i+1) - y(i))/d(i); c(i) = c(i+1) - c(i) End Do ! end conditions. third derivatives at x(1) and x(n) ! obtained from divided dIfferences b(1) = -d(1); b(n) = -d(n-1); c(1) = zero; c(n) = zero If (n.Ne.3) Then c(1) = c(3)/(x(4)-x(2))-c(2)/(x(3)-x(1)) c(n) = c(n-1)/(x(n)-x(n-2))-c(n-2)/(x(n-1)-x(n-3)) c(1) = c(1)*d(1)**2/(x(4)-x(1)) c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3)) ! forward elimination Else Do i = 2, n t = d(i-1)/b(i-1); b(i) = b(i) - t*d(i-1); c(i) = c(i) - t*c(i-1) End Do End If ! back substitution c(n) = c(n)/b(n) Do ib = 1, nm1 i = n-ib c(i) = (c(i) - d(i)*c(i+1))/b(i) End Do ! compute polynomial coefficients b(n) = (y(n) - y(nm1))/d(nm1) + d(nm1)*(c(nm1) + two*c(n)) Do i = 1, nm1 b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + two*c(i)) d(i) = (c(i+1) - c(i))/d(i); c(i) = tr*c(i) End Do c(n) = tr*c(n); d(n) = d(n-1) Return Else b(1) = (y(2)-y(1))/(x(2)-x(1)); c(1) = zero; d(1) = zero Return End If End Subroutine csplin !======================================================================= ! !======================================================================= Subroutine cseval(n,u,x,y,b,c,d,splf0) !--------------------------------------------------------------------- ! This subroutine is a copy of 'cseva' but only for the function !--------------------------------------------------------------------- Integer(ipr) :: n Integer(ipr), Save :: i=1,j,k Real(pr) :: x(n),y(n),b(n),c(n),d(n),u,splf0 Real(pr), Save :: dx If(i.Ge.n) i = 1 If(u.Lt.x(i)) Go To 10 If(u.Le.x(i+1)) Go To 30 ! binary search 10 i = 1 j = n + 1 20 k = (i+j)/2 If(u.Lt.x(k)) j = k If(u.Ge.x(k)) i = k If(j.Gt.i+1) Go To 20 ! evaluate splf0 30 dx = u - x(i) splf0 = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i))) Return End Subroutine cseval !======================================================================= ! !======================================================================= Subroutine deri(h,n,f1,dunl) !--------------------------------------------------------------------- ! First derivative of 'f1' if the step is 'h' !--------------------------------------------------------------------- Integer(ipr) :: n Integer(ipr), Save :: k Real(pr) :: h,f1(n),dunl(n) Real(pr), Save :: t60,t12 Real(pr), Save :: t8=8.0_pr,t45=45.0_pr,t9=9.0_pr t60 =1.0_pr/(h*60.0_pr); t12 =1.0_pr/(h*12.0_pr) ! dunl(1) =(t8*f1(2)-f1(3)+f1(1))*t12 dunl(2) =(t45*(f1(3)-f1(1))-t9*f1(4)+f1(5)-f1(1))*t60 dunl(3) =(t45*(f1(4)-f1(2))-t9*(f1(5)-f1(1))+f1(6))*t60 dunl(n) =(-t8*f1(n-1)+f1(n)+f1(n-2))*t12 dunl(n-1)=(t45*(f1(n)-f1(n-2))+t9*f1(n-3)-f1(n)-f1(n-4))*t60 dunl(n-2)=(t45*(f1(n-1)-f1(n-3))-t9*(f1(n)-f1(n-4))-f1(n-5))*t60 Do k=4,n-3 dunl(k) =(t45*(f1(k+1)-f1(k-1))-t9*(f1(k+2)-f1(k-2))+f1(k+3)-f1(k-3))*t60 End Do Return End Subroutine deri ! End Module linear_algebra !================================================================================================================================== !#END linear_algebra MODULE !================================================================================================================================== !================================================================================================================================== !#START UNEDF MODULE !================================================================================================================================== Module UNEDF !-------------------------------------------------------------------------------------- ! M.Kortelainen & M.Stoitsov, 2009-2011 ! UNEDF interface for Skyrme, DME(LO,NLO,N2LO) and other DFT solvers !-------------------------------------------------------------------------------------- Use HFBTHO_utilities Implicit None ! Character(16), Private :: Version='17' ! ! Version History !-------------------------------------------------------------------------------------- ! ver#17:(Mario) use_TMR_pairing=0/1 standard/TMR pairing added ! to Namelist. Using: ! CpV0(0)=G, CpV0(1)=a ! CpV1(0)=vfacn,CpV1(1)=vfacp ! ver#16:(Mario) #ifndef hide_dme preprocessing directive included ! ver#15:(Markus) Added parameter CExPar, used in Coul. excange term. ! Also, all the channels included in direct Hartree ! ver#14:(Markus) Added function Vexternal for the external field, ! and use_j2terms to switch off tensor terms. ! Direct Hartree set to zero. ! Ver#13:(Mario) Added ac2,ac3,acoord ! ver#12:(Mario) hartree term temprorary dropped. rDr NNN terms taken ! with a factor of 1/2 ! ver#11:(Mario) Gaussian approximation to the Hartree term added, ! [3/10/2010] hatree_rc removed. NB! Function HartreeV is an ! elemental function with possible array arguments ! ver#10: (Markus) Added e2charg (e^2 for Coulomb) to the public variables ! ver#9: (Mario) Hartree 'CHrho' calculated in INM with rc='hatree_rc' ! [2/2/2010] is subtracted from Crho(0)at DMEorder >= 0. ! CHrho added to the public list, 'hatree_rc' added ! to interaction parameters and the namelist. ! In the case DMEorder=-1 (standard Skyrme) ! both, 'CHrho' and 'hatree_rc', do not play. ! New function HartreeV(u) defines Hatree energy as ! E(Hartree)=(1/2)*Int[rho_0(r)*V(|r-r'|)*rho_0(r')] ! HartreeV(u) is zero for u=<'hatree_rc' ! ver#8: (Markus) Hartree DME terms dropped out. ! ver#7: (Markus) Added switch to turn off the 3N terms. ! (Mario) Added Abs to density and gradient dependent LDA ! Public :: DMEorder,DMElda,use_DME3N_terms ! ver#6: (Mario) Skyrme transformation added. ! ver#5: (Mario) Print_Namelist=T/F added to the namelist ! ver#4: (Markus) Added natural units to the module. Used only for printing. ! ver#3: (Mario) Uamplitudes(0:3,0:7) in normal order ! ! t for Uamplitudes(t,*) ! 0 -> 0,0 ! 1 -> 1,1 ! 2 -> 0,1 ! 3 -> 1,0 ! n for Uamplitudes(*,n) ! 0 -> U ! 1 -> dU/dRHO_0 ! 2 -> dU/dRHO_1 ! 3 -> d2U/(dRHO_0*dRHO_0) ! 4 -> d2U/(dRHO_1*dRHO_1) ! 5 -> d2U/(dRHO_0*dRHO_1) ! 6 -> dU/d(TAU_0) ! 7 -> dU/d(Delta RHO_0) ! ! TESTED MATTHEMETICA<=>BIRUC & SCOTT; MATTHEMETICA<=>Module UNEDF (energy amplitudes only) ! ver#2: (Mario) Pairing included ! - set_functional_parameters(fname,lpr) ! - pairing incorporated into CpV0(0:1),CpV1(0:1) ! as public variables also serving two public amplitudes ! Urhorhopr(0:1,0)=CpV0(0:1)+CpV1(0:1)*rho(0) ! Urhorhopr(0:1,1)=CpV1(0:1) ! so, they can be used with appropriate values by the DME solver ! -need improvement later, ! currently HFBTHO uses CpV0(0:1), CpV0(0:1) as before ! just substituting V0,V1 in pn-representation ! CpV0*(1-CpV1/0.16*rho_0)and this defines ! the default values in the module CpV0=V0,CpV1=1/2) ! -NAMELIST and input/output modified. RESERVED NAMES ARE: ! -namelist forbiden: ! 'UNRDF' - best UNEDF ! 'SKYRME' - best SKYRME ! -namelist inforced but not for C-parameters (use_INM=F) ! or NM-parameters (use_INM=T) defined by the solver ! 'FITS' ! -namelist inforced (one can overwrite all): ! 'ANY OTHER NAME' ! i.e., the solver defines C-/NM- only using 'FITS' ! ver#1: (Mario) Complete rewrite consistent with HFBTHO ! -CB-LDA added ! -INM added ! -HFBTHO BENCHMARK: LN, ZR(110) prolate solution with SLY4, ! mixed pairing and tensor terms. Agreement with previouse ! implemetation to the last significant digit in the cases: ! - Standard Skyrme ! - LO+LDA ! - LO+CB-LDA ! - (NrNr=0,rDj=0), (rDr=0,jDr=0), 0.5(NrNr=-rDr,jDr=-rDj) ! -use_j2terms removed, i.e., in the SKYRME case CJ=0 removes all ! tensor terms, while in DME tensor terms are always present ! ver#0: (Marcus) Basic coding from scratch ! -DME(u) consistent with Mathematica numbers ! -including small 'u' approximation !-------------------------------------------------------------------------------------- ! ! === PUBLIC VARIABLES === ! ! Use pointers to prevent conflicts with UNEDF public variabes ! Example: Use UNEDF, pr=>my_pr, ipr=>my_ipr, Crho=>my_Crho ... ! !-------------------------------------------------------------------------------------- !Integer, Parameter, Public :: ipr=Kind(1) ! to set the precision of the DFT solver !Integer, Parameter, Public :: pr=Kind(1.000D0) ! to set the precision of the DFT solver Logical, Public :: use_charge_density, use_cm_cor,use_DME3N_terms, & use_j2terms,use_full_cm_cor,use_INM,use_Namelist, & Print_Namelist Integer(ipr), Public :: DMEorder,DMElda,use_TMR_pairing Real(pr), Public, Dimension(0:3,0:7) :: Urhorho,Urhotau,UrhoDrho,Unablarho ! ph DME amplitudes Real(pr), Public, Dimension(0:3,0:7) :: UJnablarho,UrhonablaJ,UJJ Real(pr), Public, Dimension(0:3,0:7) :: Urhorhopr ! pp amplitudes Real(pr), Public, Dimension(0:1) :: UEnonstdr,UFnonstdr,URnonstdr ! Other amplitudes Real(pr), Public :: hbzero,sigma,e2charg,CExPar ! hbr^2/2m, DD sigma, e^2 charge, coul.exch. Real(pr), Public, Dimension(0:1) :: Crho,Cdrho,Ctau,CrDr,CrdJ,CJ,CpV0,CpV1 ! basic coupling constants Real(pr), Public :: E_NM,K_NM,SMASS_NM,RHO_NM,ASS_NM,LASS_NM,VMASS_NM,P_NM,KA_NM Real(pr), Public :: CHrho ! Crho(0) from the Hartree term in NM Real(pr), Public :: mpi,gA,fpi,c1,c3,c4,cd,ce,LambdaX Real(pr), PUBLIC :: t0s,t0a,drs,dra,ts,ta,t3alp,t3al0,t3alm,t324,alp,alm,wla0, & wla1,TA7,TA8,TB7,TB8,tv1,tv2,tv3,tv4,tv5,tv6,ts1,ts2,t4o3 Real(pr), PUBLIC :: t0_pub,t1_pub,t2_pub,t3_pub,x0_pub,x1_pub,x2_pub,x3_pub,& b4_pub,b4p_pub,te_pub,to_pub ! ! === PRIVATE VARIABLES === ! Real(pr), Private, Dimension(0:1) :: nuCrho,nuCdrho,nuCtau,nuCrDr ! basic coupling constants in natural units Real(pr), Private, Dimension(0:1) :: nuCrdJ,nuCJ,nuCpV0,nuCpV1 ! Real(pr), Private :: t0,t1,t2,t3,x0,x1,x2,x3,b4,b4p,te,to Real(pr), Private :: nuLambda,nufpi ! parameters associated to natural units Real(pr), Private, Dimension(0:1) :: Cnrho,CJdr ! hidden and always zero Integer(ipr), Private :: i_cut ! dmeorder: -1=Standard Skyrme, 0=LO, 1=NLO, 2=N2LO Real(pr), Private :: Pi,eps ! dmelda: 0=Kf-LDA, 1=CB-LDA Real(pr), Private :: kfconst,CK ! (3Pi^2/2)^(1/3) Real(pr), Parameter, Private :: mevfm=197.30_pr; Real(pr), Private :: rho(0:1),tau(0:1),nrho2(0:1),lrho(0:1) Real(pr), Private :: mpi2,fpi2,fpi4,gA2,gA4,gA6,CHartree Real(pr), Private :: arhorho,brhorho,arhodrho,brhodrho,arhotau,brhotau,ajj,bjj,adrdr,bdrdr Real(pr), Private :: darhorho,dbrhorho,darhodrho,dbrhodrho,darhotau,dbrhotau,dajj,dbjj,dadrdr,dbdrdr Real(pr), Private :: ddarhodrho,ddbrhodrho,ddarhotau,ddbrhotau,ddarhorho,ddbrhorho Real(pr), Private :: hrho0rho0,hrho1rho1,hdr0dr0,hdr1dr1,hrho0Drho0,hrho1Drho0, & hrho1Drho1,hrho0tau0,hrho1tau0,hrho1tau1,hJ0dr0,hrho0DJ0,hJ1dr1,hrho1DJ1, & hJ0dr1,hrho1DJ0,hJ1dr0,hJ0J0,hJ0J1,hJ1J1 Real(pr), Private :: dhrho0rho0,dhrho1rho1,dhdr0dr0,dhdr1dr1,dhrho0Drho0, & dhrho1Drho0,dhrho1Drho1,dhrho0tau0,dhrho1tau0,dhrho1tau1,dhJ0dr0,dhrho0DJ0, & dhJ1dr1,dhrho1DJ1,dhJ0dr1,dhrho1DJ0,dhJ1dr0,dhJ0J0,dhJ0J1,dhJ1J1 Real(pr), Private :: ddhrho0rho0,ddhrho1rho1,ddhrho0Drho0,ddhrho1Drho0, & ddhrho1Drho1,ddhrho0tau0,ddhrho1tau0,ddhrho1tau1 Real(pr), Private, Dimension(3,3,33) :: ctr0r0,ctr1r1,ctdr0dr0,ctdr1dr1, & ! coefficients for 3N part ctr0Dr0,ctr1Dr0,ctr1Dr1,ctr0t0,ctr1t0,ctr1t1,ctJ0dr0,ctr0dJ0,ctJ1dr1, & ctr1dJ1,ctJ0dr1,ctr1dJ0,ctJ1dr0,ctJ0J0,ctJ0J1,ctJ1J1 Real(pr), Private :: u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12 Real(pr), Private :: ual,lual,atu,asqu,asqu4 Real(pr), Private :: ac2,ac3,acoord Parameter(acoord=0.50_pr,ac2=4.0_pr*(acoord**2-acoord+0.50_pr),ac3=2.0_pr*(acoord**2-acoord+0.50_pr)) Character (30) :: FunctionalName ! Real(pr), Private :: A1_1,A1_2,A1_3,A1_4,A1_5,b1_1,b1_2,b1_3,b1_4,b1_5 Real(pr), Private :: A3_1,A3_2,A3_3,A3_4,A3_5,b3_1,b3_2,b3_3,b3_4,b3_5 Real(pr), Private :: h0mpi6,h0mpi6c1,h0mpi6c3,h0mpi6NM,h0mpi6c1NM,h0mpi6c3NM ! Namelist /UNEDF_NAMELIST/ FunctionalName, DMEorder, DMElda, use_INM, hbzero, use_TMR_pairing, & Crho, Cdrho, Ctau, CrDr, CrdJ, CJ, sigma, CpV0, CpV1, e2charg, & E_NM, K_NM, SMASS_NM, RHO_NM, ASS_NM, LASS_NM, VMASS_NM, & mpi, gA, fpi, c1, c3, c4, cd, ce, LambdaX, & use_cm_cor, use_charge_density, use_DME3N_terms, use_j2terms, CExPar, & Print_Namelist Contains ! !=============================================================================================== Subroutine calculate_U_parameters(rho0_in,rho1_in,tau0_in,tau1_in,laprho0,laprho1,nablarho0s,nablarho1s) Implicit None Real(pr), Intent(in) :: rho0_in,rho1_in,tau0_in,tau1_in Real(pr), Intent(in), Optional :: & nablarho0s,nablarho1s,laprho0,laprho1 Integer(ipr) :: t,i,j,k,l Real(pr) :: u,du,ddu,dtu,dlu Real(pr) :: ph,aux,daux,ddaux Real(pr) :: y,dy,ddy,marc,dmarc,ddmarc,mlog,dmlog,ddmlog Real(pr) :: ucut,ucut3n ! ucut=0.1_pr; ucut3n=0.6_pr ! rho(0)=rho0_in; rho(1)=rho1_in; tau(0)=tau0_in; tau(1)=tau1_in; ! lrho=0.0_pr; nrho2=0.0_pr; If (Present(laprho0)) lrho(0)=laprho0 If (Present(laprho1)) lrho(1)=laprho1 If (Present(nablarho0s)) nrho2(0)=nablarho0s If (Present(nablarho1s)) nrho2(1)=nablarho1s ! arhorho=0.0_pr; darhorho=0.0_pr; ddarhorho=0.0_pr brhorho=0.0_pr; dbrhorho=0.0_pr; ddbrhorho=0.0_pr arhodrho=0.0_pr; darhodrho=0.0_pr; ddarhodrho=0.0_pr brhodrho=0.0_pr; dbrhodrho=0.0_pr; ddbrhodrho=0.0_pr arhotau=0.0_pr; darhotau=0.0_pr; ddarhotau=0.0_pr brhotau=0.0_pr; dbrhotau=0.0_pr; ddbrhotau=0.0_pr adrdr=0.0_pr; dadrdr=0.0_pr bdrdr=0.0_pr; dbdrdr=0.0_pr ajj=0.0_pr; dajj=0.0_pr bjj=0.0_pr; dbjj=0.0_pr ! hrho0rho0=0.0_pr; hrho1rho1=0.0_pr; hdr0dr0=0.0_pr; hdr1dr1=0.0_pr hrho0Drho0=0.0_pr; hrho1Drho0=0.0_pr; hrho1Drho1=0.0_pr hrho0tau0=0.0_pr; hrho1tau0=0.0_pr; hrho1tau1=0.0_pr hJ0dr0=0.0_pr; hrho0DJ0=0.0_pr; hJ1dr1=0.0_pr; hrho1DJ1=0.0_pr hJ0dr1=0.0_pr; hrho1DJ0=0.0_pr; hJ1dr0=0.0_pr hJ0J0=0.0_pr; hJ0J1=0.0_pr; hJ1J1=0.0_pr dhrho0rho0=0.0_pr; dhrho1rho1=0.0_pr; dhdr0dr0=0.0_pr; dhdr1dr1=0.0_pr dhrho0Drho0=0.0_pr; dhrho1Drho0=0.0_pr; dhrho1Drho1=0.0_pr dhrho0tau0=0.0_pr; dhrho1tau0=0.0_pr; dhrho1tau1=0.0_pr dhJ0dr0=0.0_pr; dhrho0DJ0=0.0_pr; dhJ1dr1=0.0_pr; dhrho1DJ1=0.0_pr dhJ0dr1=0.0_pr; dhrho1DJ0=0.0_pr; dhJ1dr0=0.0_pr dhJ0J0=0.0_pr; dhJ0J1=0.0_pr; dhJ1J1=0.0_pr ddhrho0rho0=0.0_pr; ddhrho1rho1=0.0_pr ddhrho0Drho0=0.0_pr; ddhrho1Drho0=0.0_pr; ddhrho1Drho1=0.0_pr ddhrho0tau0=0.0_pr; ddhrho1tau0=0.0_pr; ddhrho1tau1=0.0_pr ! u=0.0_pr; du=0.0_pr; ddu=0.0_pr; dtu=0.0_pr; dlu=0.0_pr ! Urhorho=0.0_pr ; Urhotau=0.0_pr UrhoDrho=0.0_pr ; Unablarho=0.0_pr UJnablarho=0.0_pr; UrhonablaJ=0.0_pr Urhorhopr=0.0_pr ; UJJ=0.0_pr UEnonstdr=0.0_pr ; UFnonstdr=0.0_pr ; URnonstdr=0.0_pr ! ! Notations for Uamplitudes(0:3,0:7) ! t for Uamplitudes(t,*) ! 0 -> 0,0 ! 1 -> 1,1 ! 2 -> 0,1 ! 3 -> 1,0 ! n for Uamplitudes(*,n) ! 0 -> U ! 1 -> dU/dRHO_0 ! 2 -> dU/dRHO_1 ! 3 -> d2U/(dRHO_0*dRHO_0) ! 4 -> d2U/(dRHO_1*dRHO_1) ! 5 -> d2U/(dRHO_0*dRHO_1) ! 6 -> dU/d(TAU_0) ! 7 -> dU/d(Delta RHO_0) ! !! 2N terms Do t=0,1 ph=1.0_pr If(t.Eq.1) ph=-1.0_pr Urhorho(t,0)=Crho(t)+Cdrho(t)*rho(0)**sigma & +0.50_pr*(arhorho+ph*brhorho)*mevfm Urhotau(t,0)=Ctau(t)+0.50_pr*(arhotau+ph*brhotau)*mevfm UrhoDrho(t,0)=Crdr(t)+ac2*0.50_pr*(arhoDrho+ph*brhoDrho)*mevfm UJJ(t,0)=CJ(t)+0.50_pr*(ajj+ph*bjj)*mevfm Unablarho(t,0)=Cnrho(t)+0.50_pr*(adrdr+ph*bdrdr)*mevfm UrhonablaJ(t,0)=Crdj(t) UJnablarho(t,0)=Cjdr(t) Urhorho(t,1)=sigma*Cdrho(t)*(rho(0)**sigma)/(rho(0)+eps) & +0.50_pr*(darhorho+ph*dbrhorho)*du*mevfm Urhotau(t,1)=0.50_pr*(darhotau+ph*dbrhotau)*du*mevfm UrhoDrho(t,1)=ac2*0.50_pr*(darhoDrho+ph*dbrhoDrho)*du*mevfm UJJ(t,1)=0.50_pr*(dajj+ph*dbjj)*du*mevfm Unablarho(t,1)=0.50_pr*(dadrdr+ph*dbdrdr)*du*mevfm Urhorho(t,6)=0.50_pr*(darhorho+ph*dbrhorho)*dtu*mevfm Urhotau(t,6)=0.50_pr*(darhotau+ph*dbrhotau)*dtu*mevfm UrhoDrho(t,6)=ac2*0.50_pr*(darhoDrho+ph*dbrhoDrho)*dtu*mevfm UJJ(t,6)=0.50_pr*(dajj+ph*dbjj)*dtu*mevfm Unablarho(t,6)=0.50_pr*(dadrdr+ph*dbdrdr)*dtu*mevfm Urhorho(t,7)=0.50_pr*(darhorho+ph*dbrhorho)*dlu*mevfm Urhotau(t,7)=0.50_pr*(darhotau+ph*dbrhotau)*dlu*mevfm UrhoDrho(t,7)=ac2*0.50_pr*(darhoDrho+ph*dbrhoDrho)*dlu*mevfm UJJ(t,7)=0.50_pr*(dajj+ph*dbjj)*dlu*mevfm Unablarho(t,7)=0.50_pr*(dadrdr+ph*dbdrdr)*dlu*mevfm Urhorho(t,3)=sigma*(sigma-1.0_pr)*Cdrho(t)*(rho(0)**sigma)/(rho(0)**2+eps) & +0.50_pr*(darhorho+ph*dbrhorho)*ddu*mevfm & +0.50_pr*(ddarhorho+ph*ddbrhorho)*du*du*mevfm Urhotau(t,3)=0.50_pr*(darhotau+ph*dbrhotau)*ddu*mevfm & +0.50_pr*(ddarhotau+ph*ddbrhotau)*du*du*mevfm UrhoDrho(t,3)=ac2*0.50_pr*(darhoDrho+ph*dbrhoDrho)*ddu*mevfm & +ac2*0.50_pr*(ddarhoDrho+ph*ddbrhoDrho)*du*du*mevfm End Do Urhorhopr(0,0) = CpV0(0)*(1.0_pr-CpV1(0)*rho(0)/0.16_pr) & +CpV0(1)*(1.0_pr-CpV1(1)*rho(0)/0.16_pr) Urhorhopr(1,0) = CpV0(0)*(1.0_pr-CpV1(0)*rho(0)/0.16_pr) & +CpV0(1)*(1.0_pr-CpV1(1)*rho(0)/0.16_pr) Urhorhopr(2,0) = (CpV0(0)*(1.0_pr-CpV1(0)*rho(0)/0.16_pr) & -CpV0(1)*(1.0_pr-CpV1(1)*rho(0)/0.16_pr))*2.0_pr Urhorhopr(0,1) = (-CpV0(0)*CpV1(0)-CpV0(1)*CpV1(1))/0.16_pr Urhorhopr(1,1) = (-CpV0(0)*CpV1(0)-CpV0(1)*CpV1(1))/0.16_pr Urhorhopr(2,1) = 2.0_pr*(-CpV0(0)*CpV1(0)+CpV0(1)*CpV1(1))/0.16_pr Urhorhopr=Urhorhopr/16.0_pr ! If (.Not.use_j2terms) Then UJJ=0.0_pr End If ! End Subroutine calculate_U_parameters !=============================================================================================== ! !=============================================================================================== Subroutine read_UNEDF_NAMELIST(fname,noForces) Use HFBTHO_utilities, Only: lout !-------------------------------------------------------------------------------- ! RESERVED NAMES ARE: ! -namelist forbiden: ! 'UNEDF' - best UNEDF ! 'SKYRME' - best SKYRME ! -namelist inforced but not for C-parameters (use_INM=F) ! or NM-parameters (use_INM=T) defined by the solver ! 'FITS' ! -namelist inforced (one can overwrite all): ! 'ANY OTHER NAME' ! i.e., the DME solver defines C-/NM- only using 'FITS' !-------------------------------------------------------------------------------- Implicit None Character (30), Intent(inout) :: fname Character (30) :: inforcedname Logical :: regularization Integer(ipr) :: ios,lnamelist=16,noForces ! ! parameters eps = Spacing(1.0_pr) Pi = 4.0_pr*Atan(1.0_pr) kfconst =(1.50_pr*Pi**2)**(1.0_pr/3.0_pr) ! (3Pi^2/2)^(1/3) CK = 3.0_pr/5.0_pr*kfconst**2 ! use_Namelist=.True. Do !--------------------------------------------------------------------- ! Some default values for all cases !--------------------------------------------------------------------- Print_Namelist=.False. FunctionalName="Bla-Bla" ! kind of the functional use_INM = .False. use_DME3N_terms = .False. use_charge_density = .False. regularization = .False. use_cm_cor = .False. use_full_cm_cor = .False. use_j2terms = .False. use_TMR_pairing = 0 DMEorder = -1 DMElda = 0 ! Coupling constants: ph channel Crho(0) = -727.0933239596374733_pr; Crho(1) = 474.8709969984467989_pr CDrho(0) = 612.1037411660222460_pr; CDrho(1) = -705.7204872069220301_pr Ctau(0) = 33.8846741217252401_pr; Ctau(1) = 32.4047409594248919_pr CrDr(0) = -76.9962031249999939_pr; CrDr(1) = 15.6571351249999999_pr CrdJ(0) = -92.2500000000000000_pr; CrdJ(1) = -30.7500000000000000_pr CJ(0) = 17.2096115000000012_pr; CJ(1) = 64.5758124999999978_pr Cnrho = 0.0000000000000000_pr; CJdr = 0.0000000000000000_pr ! Coupling constants: pp channel CpV0 = -258.2000000000000000_pr; CpV1 = 0.5000000000000000_pr ! Various sigma = 0.3062227576210547_pr; hbzero = 20.7355300000000007_pr; e2charg = 1.4399784085965135_pr ; CExPar = 1.0_pr ! DME mpi= 138.03_pr/197.3_pr; fpi = 92.4_pr/197.3_pr; gA = 1.29_pr c1 = -0.81_pr/1000.0_pr*197.3_pr c3 = -3.40_pr/1000.0_pr*197.3_pr c4 = 3.40_pr/1000.0_pr*197.3_pr cd = -2062.00_pr/1000.0_pr ce = -625.00_pr/1000.0_pr ! Natural units LambdaX = 700.0_pr/197.3_pr; nuLambda = 700.0_pr; nufpi = 93.0_pr ! Nuclear matter E_NM = -15.972149141444596410_pr; RHO_NM = 0.159538756711733398_pr K_NM = 229.900964482603626493_pr; SMASS_NM = 1.439546988976078357_pr ASS_NM = 32.004302815052007247_pr; LASS_NM = 45.961751480461579433_pr VMASS_NM = 1.249838547196253424_pr !--------------------------------------------------------------------- ! Select the functional: start with interaction !--------------------------------------------------------------------- noForces=0 ! No forces to start with Call skforce(fname,noForces) ! If (noForces.Eq.1) Then inforcedname='FORCE' use_Namelist=.False. Else FUNCTIONAL: Select Case (Trim(fname)) Case ('UNE0') inforcedname='UNE0' use_Namelist=.False. ! kind of the functional use_INM = .True. use_cm_cor = .True. ! Surface coefficients CrDr(0) = -55.260600000000000_pr CrDr(1) = -55.622600000000000_pr CpV0(0) = -170.374000000000000_pr CpV0(1) = -199.202000000000000_pr CrdJ(0) = -79.530800000000000_pr CrdJ(1) = 45.630200000000000_pr CJ(0) = 0.000000000000000_pr CJ(1) = 0.000000000000000_pr CExPar = 1.000000000000000_pr ! Various Cnrho = 0.000000000000000_pr CJdr = 0.000000000000000_pr hbzero = 20.735530000000000_pr e2charg = 1.439978408596513_pr ! Associated INM parameters RHO_NM = 0.160526000000000_pr E_NM = -16.055900000000000_pr P_NM = 0.000000000000000_pr K_NM = 230.000000000000000_pr ASS_NM = 30.542900000000000_pr LASS_NM = 45.080400000000000_pr SMASS_NM = 0.900000000000000_pr VMASS_NM = 1.249838000000000_pr Case ('UNE1') inforcedname='UNE1' use_Namelist=.False. ! kind of the functional use_INM = .True. ! Surface coefficients CrDr(0) = -45.135131022237300_pr CrDr(1) = -145.382167908057000_pr CpV0(0) = -186.065399575124000_pr CpV0(1) = -206.579593890106000_pr CrdJ(0) = -74.026333176459900_pr CrdJ(1) = -35.658261114791700_pr CJ(0) = 0.000000000000000_pr CJ(1) = 0.000000000000000_pr CExPar = 1.000000000000000_pr ! Various Cnrho = 0.000000000000000_pr CJdr = 0.000000000000000_pr hbzero = 20.735530000000000_pr e2charg = 1.439978408596513_pr ! Associated INM parameters RHO_NM = 0.158706769332587_pr E_NM = -15.800000000000000_pr P_NM = 0.000000000000000_pr K_NM = 220.000000000000000_pr ASS_NM = 28.986789057772100_pr LASS_NM = 40.004790480413600_pr SMASS_NM = 0.992423332283364_pr VMASS_NM = 1.249838574232270_pr Case ('UNE2') inforcedname='UNE2' use_Namelist=.False. ! kind of the functional use_INM = .True. use_j2terms = .True. ! Surface coefficients CrDr(0) = -46.831409147060600_pr CrDr(1) = -113.163790795259000_pr CpV0(0) = -208.889001962571000_pr CpV0(1) = -230.329984038628000_pr CrdJ(0) = -64.308862415783800_pr CrdJ(1) = -38.650194685135500_pr CJ(0) = -54.433363597372100_pr CJ(1) = -65.903031044593800_pr CExPar = 1.000000000000000_pr ! Various Cnrho = 0.000000000000000_pr CJdr = 0.000000000000000_pr hbzero = 20.735530000000000_pr e2charg = 1.439978408596513_pr ! Associated INM parameters RHO_NM = 0.156310622197074_pr E_NM = -15.800000000000000_pr P_NM = 0.000000000000000_pr K_NM = 239.929568022437000_pr ASS_NM = 29.131006470773700_pr LASS_NM = 40.000000000000000_pr SMASS_NM = 1.073763804147980_pr VMASS_NM = 1.249838574232270_pr Case ('N0LO') inforcedname='N0LO' use_Namelist=.False. ! kind of the functional use_INM = .True. use_j2terms = .False. use_DME3N_terms = .False. DMEorder = 0 ! Surface coefficients CrDr(0) = -67.437_pr CrDr(1) = 21.551_pr CpV0(0) = -241.203_pr CpV0(1) = -252.818_pr CrdJ(0) = -95.451_pr CrdJ(1) = -65.906_pr CJ(0) = 0.000_pr CJ(1) = 0.000_pr CExPar = 1.000_pr ! Various Cnrho = 0.000000000000000_pr CJdr = 0.000000000000000_pr hbzero = 20.735530000000000_pr e2charg = 1.439978408596513_pr ! Associated INM parameters RHO_NM = 0.1595_pr E_NM = -15.9700_pr P_NM = 0.0000_pr K_NM = 229.9000_pr ASS_NM = 32.0000_pr LASS_NM = 45.9600_pr SMASS_NM = 1.4400_pr VMASS_NM = 1.2500_pr Case ('N1LO') inforcedname='N1LO' use_Namelist=.False. ! kind of the functional use_INM = .True. use_j2terms = .False. use_DME3N_terms = .False. DMEorder = 1 ! Surface coefficients CrDr(0) = -63.996_pr CrDr(1) = -9.276_pr CpV0(0) = -241.484_pr CpV0(1) = -252.222 CrdJ(0) = -95.463_pr CrdJ(1) = -60.800_pr CJ(0) = 0.000_pr CJ(1) = 0.000_pr CExPar = 1.000_pr ! Various Cnrho = 0.000000000000000_pr CJdr = 0.000000000000000_pr hbzero = 20.735530000000000_pr e2charg = 1.439978408596513_pr ! Associated INM parameters RHO_NM = 0.1595_pr E_NM = -15.9700_pr P_NM = 0.0000_pr K_NM = 229.9000_pr ASS_NM = 32.0000_pr LASS_NM = 45.9600_pr SMASS_NM = 1.4400_pr VMASS_NM = 1.2500_pr Case ('N2LO') inforcedname='N2LO' use_Namelist=.False. ! kind of the functional use_INM = .True. use_j2terms = .False. use_DME3N_terms = .True. DMEorder = 2 ! Surface coefficients CrDr(0) = -197.132_pr CrDr(1) = -12.503_pr CpV0(0) = -272.164_pr CpV0(1) = -193.188_pr CrdJ(0) = -193.188_pr CrdJ(1) = 37.790_pr CJ(0) = 0.000_pr CJ(1) = 0.000_pr CExPar = 1.000_pr ! Various Cnrho = 0.000000000000000_pr CJdr = 0.000000000000000_pr hbzero = 20.735530000000000_pr e2charg = 1.439978408596513_pr ! Associated INM parameters RHO_NM = 0.1595_pr E_NM = -15.9700_pr P_NM = 0.0000_pr K_NM = 229.9000_pr ASS_NM = 32.0000_pr LASS_NM = 45.9600_pr SMASS_NM = 1.4400_pr VMASS_NM = 1.2500_pr Case default inforcedname=fname use_Namelist=.True. End Select FUNCTIONAL End If !--------------------------------------------------------------------- ! Exit loop condition !--------------------------------------------------------------------- If(.Not.use_Namelist) Exit !--------------------------------------------------------------------- ! Read namelists !--------------------------------------------------------------------- Open(lnamelist,file='UNEDF_NAMELIST.DAT',DELIM='APOSTROPHE') ! 'QUOTE' Read(UNIT=lnamelist,NML=UNEDF_NAMELIST,iostat=ios) If(ios.Ne.0) Then ! WRong entry within UNEDF_NAMELIST.DAT file Write(lout,'(1X,/,A)') 'ATTENTION: WRONG INPUT!' Write(lout,*) 'THE INPUT DATA WITH LABEL FUNCTIONALNAME=''',Trim(INFORCEDNAME),'''' Write(lout,*) 'INSIDE THE UNEDF_NAMELIST.DAT FILE IS WRONG.' Write(lout,*) 'PLESE CORECT AND TRY AGAIN!' Stop 'PROGRAM STOP IN read_UNEDF_NAMELIST' End If Close(lnamelist) If(Trim(FunctionalName).Eq.Trim(inforcedname)) Exit End Do !--------------------------------------------------------------------- ! See what the namelists modified !--------------------------------------------------------------------- INFORCED_FUNCTIONAL: Select Case (Trim(inforcedname)) Case ("FORCE") FunctionalName='FORCE' Case ("UNE0") FunctionalName='UNE0' Case ("UNE1") FunctionalName='UNE1' Case ("UNE2") FunctionalName='UNE2' Case ("N0LO") FunctionalName='N0LO' Case ("N1LO") FunctionalName='N1LO' Case ("N2LO") FunctionalName='N2LO' Case default ! Missing entry within hfbtho_NAMELIST.dat file If(Trim(FunctionalName).Ne.Trim(inforcedname)) Then Write(lout,'(1X,/,A)') 'ATTENTION: MISSING INPUT!' Write(lout,*) 'THE INPUT DATA WITH LABEL FUNCTIONALNAME=''',Trim(INFORCEDNAME),'''' Write(lout,*) 'IS MISSING INSIDE THE UNEDF_NAMELIST.DAT FILE.' Write(lout,*) 'PLESE CORECT AND TRY AGAIN!' Stop 'PROGRAM STOP IN SET_FUNCTIONAL_PARAMETERS' End If End Select INFORCED_FUNCTIONAL ! End Subroutine read_UNEDF_NAMELIST !=============================================================================================== ! !=============================================================================================== Subroutine skforce(fname,noForces) !--------------------------------------------------------------------- ! Set up Pairing & Skyrme force parameters and their combinations !--------------------------------------------------------------------- Use HFBTHO_utilities, Only: lout Implicit None Integer(ipr) :: noForces Real(pr) :: A,wls Real(pr) :: zero,one,two,three,four,five,six,seven,eight,nine Real(pr) :: half,pp16,pp24 Character (30), Intent(inout) :: fname ! zero = 0.0_pr; one = 1.0_pr; two = 2.0_pr; three = 3.0_pr; four = 4.0_pr five = 5.0_pr; six = 6.0_pr; seven = 7.0_pr; eight = 8.0_pr; nine = 9.0_pr half = 0.5_pr; pp16 = 16.0_pr; pp24 = 24.0_pr ! ! Default for all forces if not modified hbzero = 1.0_pr/0.04823_pr ! DMSHB0=1/hbzero sigma = one t0 = zero; x0 = zero t1 = zero; x1 = zero t2 = zero; x2 = one t3 = zero; x3 = one wls= zero; b4 = wls/two; b4p=wls/two te = zero; to = zero CExPar=1.0_pr ! noForces=0 ! No forces at all ! INTERACTION: Select Case (Trim(fname)) !--------------------------------------------------------------------- ! SIII force, Beiner et al., NPA238 (1975) 29 !--------------------------------------------------------------------- Case ('SIII') ! ph-Force noForces=1 use_cm_cor = .True. hbzero = 20.73533_pr t0 = -.1128750d+04; x0 = +0.4500000_pr t1 = +.3950000d+03; x1 = +0.0000000_pr t2 = -.9500000d+02; x2 = +0.0000000_pr t3 = +.1400000d+05; x3 = +1.0000000_pr wls= +.1200000d+03; sigma = one b4=wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -265.2500_pr, -340.0625_pr /) !--------------------------------------------------------------------- ! SKM* forces !--------------------------------------------------------------------- Case ('SKM*') ! ph-Force noForces=1 use_cm_cor = .True. hbzero = 20.73_pr t0 = -.2645000d+04; x0 = +.0900000_pr t1 = +.4100000d+03; x1 = +.0000000_pr t2 = -.1350000d+03; x2 = +.0000000_pr t3 = +.1559500d+05; x3 = +.0000000_pr wls= +.1300000d+03; sigma = one/six b4=wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -265.2500_pr, -340.0625_pr /) !--------------------------------------------------------------------- ! SKP force, Dobaczewski et al., NPA422 (1984) 103 !--------------------------------------------------------------------- Case ('SKP') ! ph-Force noForces=1 use_cm_cor = .True. use_j2terms = .True. hbzero = 20.730_pr t0 =-0.2931696d+04; x0 = 0.2921515_pr t1 = 0.3206182d+03; x1 = 0.6531765_pr t2 =-0.3374091d+03; x2 =-0.5373230_pr t3 = 0.1870896d+05; x3 = 0.1810269_pr wls= 0.1000000d+03; sigma=one/six b4=wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -265.2500_pr, -340.0625_pr /) !--------------------------------------------------------------------- ! SLY4 force !--------------------------------------------------------------------- Case ('SLY4') ! ph-Force noForces=1 use_cm_cor = .True. hbzero = 20.735530_pr t0 =-0.2488913d+04; x0 = 0.8340000_pr t1 = 0.4868180d+03; x1 =-0.3440000_pr t2 =-0.5463950d+03; x2 =-1.0000000_pr t3 = 0.1377700d+05; x3 = 1.3540000_pr wls= 0.1230000d+03; sigma=one/six b4 = wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -325.2500_pr, -340.0625_pr /) ! HFB !--------------------------------------------------------------------- ! SLY5 force !--------------------------------------------------------------------- Case ('SLY5') ! ph-Force noForces=1 use_cm_cor = .True. use_j2terms = .True. hbzero = 20.73553_pr t0 =-0.2483450d+04; x0 = 0.7760000_pr t1 = 0.4842300d+03; x1 =-0.3170000_pr t2 =-0.5566900d+03; x2 =-1.0000000_pr t3 = 0.1375700d+05; x3 = 1.2630000_pr wls= 0.1250000d+03; sigma=one/six b4 = wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -291.5000_pr, -297.7402_pr /) ! HFB !--------------------------------------------------------------------- ! SLY6 forces !--------------------------------------------------------------------- Case ('SLY6') ! ph-Force noForces=1 use_cm_cor = .True. use_full_cm_cor = .True. hbzero = 20.73553_pr t0 =-0.2479500d+04; x0 = 0.8250000_pr t1 = 0.4621800d+03; x1 =-0.4650000_pr t2 =-0.4486100d+03; x2 =-1.0000000_pr t3 = 0.1367300d+05; x3 = 1.3550000_pr wls= 0.1220000d+03; sigma=one/six b4=wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -291.5000_pr, -297.7402_pr /) ! HFB !--------------------------------------------------------------------- ! SLY6 forces !--------------------------------------------------------------------- Case ('SLY7') ! ph-Force noForces=1 use_cm_cor = .True. use_j2terms = .True. use_full_cm_cor = .True. hbzero = 20.73553_pr t0 =-0.2480800d+04; x0 = 0.8480000_pr t1 = 0.4612900d+03; x1 =-0.4920000_pr t2 =-0.4339300d+03; x2 =-1.0000000_pr t3 = 0.1366900d+05; x3 = 1.3930000_pr wls= 0.1250000d+03; sigma=one/six b4=wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -291.5000_pr, -297.7402_pr /) ! HFB !!!! !!!! THE PARAMETERIZATIONS OF THE LYON FAMILY OF SKYRME FORCES COMMENTED !!!! OUT BELOW IS COMPATIBLE WITH VERSIONS OF HFODD >= 2.52I. FOR COMPA- !!!! RISONS WITH OLDER VERSIONS OF HFODD PLEASE USE THE DEFAULT (UNCOM- !!!! MENTED) PARAMETERIZATIONS ABOVE, WHICH WAS USED FOR ALL RELEVANT !!!! BENCHMARKS IN THE CPC ARTICLE DESCRIBING HFBTHO. !!!! !!!!--------------------------------------------------------------------- !!!! SLY4 force !!!!--------------------------------------------------------------------- !!!Case ('SLY4') !!! ! ph-Force !!! noForces=1 !!! use_cm_cor = .True. !!! hbzero = 20.73553_pr !!! t0 =-0.248891d+04; x0 = 0.834_pr !!! t1 = 0.486820d+03; x1 =-0.344_pr !!! t2 =-0.546390d+03; x2 =-1.000_pr !!! t3 = 0.137770d+05; x3 = 1.354_pr !!! wls= 0.123000d+03; sigma=one/six !!! b4 = wls/two; b4p=wls/two !!! ! pp-Forces !!! CpV1=0.50_pr !!! CpV0=(/ -325.2500_pr, -340.0625_pr /) ! HFB !!!!--------------------------------------------------------------------- !!!! SLY5 force !!!!--------------------------------------------------------------------- !!!Case ('SLY5') !!! ! ph-Force !!! noForces=1 !!! use_cm_cor = .True. !!! use_j2terms = .True. !!! hbzero = 20.73553_pr !!! t0 =-0.248488d+04; x0 = 0.778_pr !!! t1 = 0.483130d+03; x1 =-0.328_pr !!! t2 =-0.549400d+03; x2 =-1.000_pr !!! t3 = 0.137630d+05; x3 = 1.267_pr !!! wls= 0.126000d+03; sigma=one/six !!! b4 = wls/two; b4p=wls/two !!! ! pp-Forces !!! CpV1=0.50_pr !!! CpV0=(/ -291.5000_pr, -297.7402_pr /) ! HFB !!!!--------------------------------------------------------------------- !!!! SLY6 forces !!!!--------------------------------------------------------------------- !!!Case ('SLY6') !!! ! ph-Force !!! noForces=1 !!! use_cm_cor = .True. !!! use_full_cm_cor = .True. !!! hbzero = 20.73553_pr !!! t0 =-0.24795d+04; x0 = 0.825_pr !!! t1 = 0.46218d+03; x1 =-0.465_pr !!! t2 =-0.44861d+03; x2 =-1.000_pr !!! t3 = 0.13673d+05; x3 = 1.355_pr !!! wls= 0.12200d+03; sigma=one/six !!! b4=wls/two; b4p=wls/two !!! ! pp-Forces !!! CpV1=0.50_pr !!! CpV0=(/ -291.5000_pr, -297.7402_pr /) ! HFB !!!!--------------------------------------------------------------------- !!!! SLY6 forces !!!!--------------------------------------------------------------------- !!!Case ('SLY7') !!! ! ph-Force !!! noForces=1 !!! use_cm_cor = .True. !!! use_j2terms = .True. !!! use_full_cm_cor = .True. !!! hbzero = 20.73553_pr !!! t0 =-0.248241d+04; x0 = 0.846_pr !!! t1 = 0.457970d+03; x1 =-0.511_pr !!! t2 =-0.419850d+03; x2 =-1.000_pr !!! t3 = 0.136770d+05; x3 = 1.391_pr !!! wls= 0.126000d+03; sigma=one/six !!! b4=wls/two; b4p=wls/two !!! ! pp-Forces !!! CpV1=0.50_pr !!! CpV0=(/ -291.5000_pr, -297.7402_pr /) ! HFB !--------------------------------------------------------------------- ! SKI3 force, P.G.-Reinhard et al. Nucl. Phys. A584 (1995) 467-488 !--------------------------------------------------------------------- Case ('SKI3') ! ph-Force noForces=1 use_cm_cor = .True. use_full_cm_cor = .True. hbzero = 20.7525_pr t0 =-0.176288d+04; x0 = 0.30830_pr t1 = 0.561608d+03; x1 =-1.17220_pr t2 =-0.227090d+03; x2 =-1.09070_pr t3 = 0.810620d+04; x3 = 1.29260_pr sigma=one/four b4 = 94.254_pr; b4p=zero ! pp-Forces CpV1=0.50_pr CpV0=(/ -357.2324_pr, -388.5625_pr /) !--------------------------------------------------------------------- ! SKO forces !--------------------------------------------------------------------- Case ('SKO') ! ph-Force noForces=1 use_cm_cor = .True. use_full_cm_cor = .True. hbzero = 20.735530_pr t0 =-0.21036530d+04; x0 = -0.2107010_pr t1 = 0.30335200d+03; x1 = -2.8107520_pr t2 = 0.79167400d+03; x2 = -1.4615950_pr t3 = 0.13553252d+05; x3 = -0.4298810_pr wls= 0.12300000d+03; sigma=one/four b4 = 0.17657800d+03; b4p=-0.1987490d+03 ! pp-Forces CpV1=0.50_pr CpV0=(/ -259.0391_pr, -274.8433_pr /) !--------------------------------------------------------------------- ! SKX forces, A.Brown; Phys.Rev. C58 (1998) 220 !--------------------------------------------------------------------- Case ('SKX') ! ph-Force noForces=1 use_cm_cor = .True. use_j2terms = .True. hbzero = 20.73_pr t0 = -1445.300_pr; x0 = 0.340_pr t1 = 246.900_pr; x1 = 0.580_pr t2 = -131.800_pr; x2 = 0.127_pr t3 = 12103.900_pr; x3 = 0.030_pr sigma=one/two b4 = 0.0743d+03; b4p=zero ! pp-Forces CpV1=0.50_pr CpV0=(/ -259.0391_pr, -274.8433_pr /) !--------------------------------------------------------------------- ! HFB9 forces !--------------------------------------------------------------------- Case ('HFB9') ! ph-Force noForces=1 use_cm_cor = .True. use_j2terms = .True. hbzero = 20.73553_pr t0 =-0.20439180d+04; x0 = 0.5149210_pr t1 = 0.41159870d+03; x1 =-0.9537990_pr t2 =-0.19418860d+03; x2 =-0.3322490_pr t3 = 0.12497170d+05; x3 = 0.8994350_pr wls= 0.14990000d+03; sigma=one/four b4=wls/two; b4p=wls/two ! pp-Forces CpV1=0.50_pr CpV0=(/ -263.5000_pr, -274.9668_pr /) !--------------------------------------------------------------------- ! Default !--------------------------------------------------------------------- Case default Write(lout,'("No Skyrme interaction defined in routine skforce()")') End Select INTERACTION ! If (noForces.Eq.1) Then ! obtain coupling constants Call C_from_t() ! Frequent combinations entering the energy tv1 = t0*(one+half*x0)*half; tv2 = t0*(x0+half)*half tv3 = t3*(one+half*x3)/12.0_pr; tv4 = t3*(x3+half)/12.0_pr tv5 = (t1*(one+half*x1)+t2*(one+half*x2))/four tv6 = (t2*(half+x2)-t1*(half+x1))/four ts1 = (t2*(one+half*x2)-three*t1*(one+half*x1))/pp16 ts2 = (t1*(half+x1)*three+t2*(half+x2))/pp16 t4o3 = four/three; t324 = t3/pp24 ! Frequent combinations entering the potential t0s = t0*(one-x0)*half; t0a = t0*(one+x0*half) drs = (t2*(one+x2)-t1*(one-x1))*three/pp16 dra = (t2*(one+half*x2)-three*t1*(one+half*x1))/eight ts = (t1*(one-x1) + three*t2*(one+x2))/eight ta = (t1*(one+half*x1) + t2*(one+half*x2))/four t3alp = t3*(two+sigma)*(two+x3)/pp24 t3al0 = t3*(x3+half)/six; t3alm = t3*sigma*(one+two*x3)/pp24 alp = one + sigma; alm = sigma - one wla0 = CrdJ(0)+CrdJ(1); wla1 = CrdJ(0)-CrdJ(1); TA7 = zero; TA8 = zero If(use_j2terms) Then TA7=(T1*(ONE-X1)-T2*(ONE+X2))/eight + five*to/four TA8=-(T1*X1+T2*X2)/four + five*(te+to)/four End If TB7 = TA7; TB8 = TA8*half End If ! Return End Subroutine skforce !=============================================================================================== ! !=============================================================================================== Subroutine set_functional_parameters(fname,lpr) !-------------------------------------------------------------------------------- ! set functional parameters !-------------------------------------------------------------------------------- Implicit None Logical, Intent(in) :: lpr Character (30), Intent(inout) :: fname Logical :: regularization Integer(ipr), Parameter :: lin=15 ! ! parameters FunctionalName=fname eps=Spacing(1.0_pr) Pi=4.0_pr*Atan(1.0_pr) kfconst=(1.50_pr*Pi**2)**(1.0_pr/3.0_pr) ! (3Pi^2/2)^(1/3) CK=3.0_pr/5.0_pr*kfconst**2 nuLambda=700.0_pr ; nufpi = 93.0_pr ! Call Make_Parameter_Free_Useful_Combinations() ! ! exact Hartree CHrho from INM CHrho=0.0_pr; !!!!If (dmeorder.eq.3) Call CHrho_from_NM() ! If(use_INM) Then Call calculate_C_from_NM(E_NM,K_NM,SMASS_NM,RHO_NM,ASS_NM,LASS_NM,VMASS_NM) Else Crho(0)=Crho(0)+CHrho End If Call calculate_NM_properties() ! Crho(0)=Crho(0)-CHrho ! Call calculate_natural_units() ! ! Print output !If(lpr) Then ! Call print_functional_parameters() !End If ! End Subroutine set_functional_parameters !=============================================================================================== ! !=============================================================================================== Subroutine print_functional_parameters() Use HFBTHO_utilities, Only: lout Implicit None ! Write(lout,'(a)') ' ---------------------------------------' Write(lout,'(a,a)') ' UNEDF Module Version:', & Trim(Version) Write(lout,'(a)') ' M.Kortelainen & M.Stoitsov ' Write(lout,'(a)') ' ---------------------------------------' ! Write(lout,'(a)') Write(lout,'(100(2x,a,a,f15.8))') Trim(FunctionalName),' functional' Write(lout,'(100(2x,a,f15.8))') '----------------------------------' Write(lout,'(" Crho(0)= ",g26.18,"; Crho(1)= ",g26.18)') Crho Write(lout,'(" CDrho(0)=",g26.18,"; CDrho(1)=",g26.18)') CDrho Write(lout,'(" Ctau(0)= ",g26.18,"; Ctau(1)= ",g26.18)') Ctau Write(lout,'(" CrDr(0)= ",g26.18,"; CrDr(1)= ",g26.18)') Crdr Write(lout,'(" CrdJ(0)= ",g26.18,"; CrdJ(1)= ",g26.18)') CrdJ Write(lout,'(" CJ(0)= ",g26.18,"; CJ(1)= ",g26.18)') CJ Write(lout,'(" CpV0(0)= ",g26.18,"; CpV0(1)= ",g26.18)') CpV0 Write(lout,'(" CpV1(0)= ",g26.18,"; CpV1(1)= ",g26.18)') CpV1 Write(lout,'(" sigma= ",g26.18,"; hbzero= ",g26.18)') sigma,hbzero Write(lout,'(" e^2 chrg=",g26.18,"; CExPar= ",g26.18)') e2charg,CExPar Write(lout,'(" c.m. correction: ",L1,", chr. density in direct Coul: ",L1)') use_cm_cor,use_charge_density Write(lout,'(" use tensor terms: ",L1)') use_j2terms Write(lout,'(" use TMR pairing: ",I1)') use_TMR_pairing ! Write(lout,'(100(2x,a,f15.8))') Write(lout,'(100(2x,a,f15.8))') 'Coupling constants in natural units' Write(lout,'(100(2x,a,f15.8))') '-----------------------------------' Write(lout,'(" Crho_nu(0)= ",g26.18,"; Crho_nu(1)= ",g26.18)') nuCrho Write(lout,'(" CDrho_nu(0)=",g26.18,"; CDrho_nu(1)=",g26.18)') nuCDrho Write(lout,'(" Ctau_nu(0)= ",g26.18,"; Ctau_nu(1)= ",g26.18)') nuCtau Write(lout,'(" CrDr_nu(0)= ",g26.18,"; CrDr_nu(1)= ",g26.18)') nuCrdr Write(lout,'(" CrdJ_nu(0)= ",g26.18,"; CrdJ_nu(1)= ",g26.18)') nuCrdJ Write(lout,'(" CJ_nu(0)= ",g26.18,"; CJ_nu(1)= ",g26.18)') nuCJ Write(lout,'(" CpV0_nu(0)= ",g26.18,"; CpV0_nu(1)= ",g26.18)') nuCpV0 Write(lout,'(" CpV1_nu(0)= ",g26.18,"; CpV1_nu(1)= ",g26.18)') nuCpV1 Write(lout,'(" fpi_nu= ",g26.18,"; Lambda_nu= ",g26.18)') nufpi,nuLambda ! If(dmeorder.Ge.0) Then Write(lout,'(100(2x,a,f15.8))') Write(lout,'(100(2x,a,f15.8))') 'DME parameters' Write(lout,'(100(2x,a,f15.8))') '----------------------------------' Write(lout,'(" gA=",f12.6," mpi [1/fm]=",f12.6," fpi [1/fm]=",f12.6)') gA,mpi,fpi Write(lout,'(" c1 [fm]=",f12.6," c3 [fm]=",f12.6," c4 [fm]=",f12.6)') c1,c3,c4 Write(lout,'(" cd=",f12.6," ce=",f12.6," LamX[1/fm]=",f12.6)') cd,ce,LambdaX Write(lout,'(" ->CHrho=",f12.6)') CHrho If(dmeorder.Ge.2) Write(lout,'(" use 3N terms: ",L1)') use_DME3N_terms End If ! Write(lout,'(100(2x,a,f15.8))') Write(lout,'(100(2x,a,f15.8))') 'Nuclear matter properties' Write(lout,'(100(2x,a,f15.8))') '----------------------------------' Write(lout,'(100(2x,a9,f25.16))') 'E_NM=',E_NM,'K_NM=',K_NM Write(lout,'(100(2x,a9,f25.16))') 'P_NM=',P_NM,'RHO_NM=',RHO_NM Write(lout,'(100(2x,a9,f25.16))') 'ASS_NM=',ASS_NM,'LASS_NM=',LASS_NM Write(lout,'(100(2x,a9,f25.16))') 'SMASS_NM=',SMASS_NM,'VMASS_NM=',VMASS_NM ! Call t_from_C() ! Write(lout,'(100(2x,a,f15.8))') Write(lout,'(100(2x,a,f15.8))') 'Associated (t,x)-coupling constants' Write(lout,'(100(2x,a,f15.8))') '-----------------------------------' Write(lout,'(" t0= ",g26.18,"; x0= ",g26.18)') t0,x0 Write(lout,'(" t1= ",g26.18,"; x1= ",g26.18)') t1,x1 Write(lout,'(" t2= ",g26.18,"; x2= ",g26.18)') t2,x2 Write(lout,'(" t3= ",g26.18,"; x3= ",g26.18)') t3,x3 Write(lout,'(" b4= ",g26.18,"; b4p= ",g26.18)') b4,b4p Write(lout,'(" te= ",g26.18,"; to= ",g26.18)') te,to Write(lout,'(" sigma= ",g26.18,"; hbzero= ",g26.18)') sigma,hbzero ! If(Print_Namelist) Then Write(lout,'(100(2x,a,f15.8))') SELECTED_FUNCTIONAL: Select Case (Trim(FunctionalName)) Case ("UNEDF","SKYRME") Write(lout,'(100(2x,a,f15.8))') 'NAMELIST CONTENT (cannot be modified for functional names UNEDF,SKYRME)' Write(lout,'(100(2x,a,f15.8))') '-----------------------------------------------------------------------' Case ("FITS") Write(lout,'(100(2x,a,f15.8))') 'NAMELIST CONTENT (Advanced usage: modify all but not C-, NM-, and more...)' Write(lout,'(100(2x,a,f15.8))') '-----------------------------------------------------------------------' Case default Write(lout,'(100(2x,a,f15.8))') 'NAMELIST CONTENT (copy/past to UNEDF_NAMELIST.DAT and modify)' Write(lout,'(100(2x,a,f15.8))') '-------------------------------------------------------------' End Select SELECTED_FUNCTIONAL Write(lout,'(100(a,f15.8))') ' !NB: FUNCTIONALNAME should be always in quotations' Write(lout,UNEDF_NAMELIST) End If End Subroutine print_functional_parameters !=============================================================================================== ! !=============================================================================================== Subroutine calculate_natural_units !-------------------------------------------------------------------------------- ! Calculates coupling constants in natural units !-------------------------------------------------------------------------------- Implicit None nuCrho = Crho*(nufpi**2)/(mevfm**3) nuCdrho = Cdrho*(nufpi**2)*((nuLambda*nufpi*nufpi)**sigma)/(mevfm**(3.0_pr*(1.0_pr+sigma))) nuCtau = Ctau*((nufpi*nuLambda)**2)/(mevfm**5) nuCrDr = CrDr*((nufpi*nuLambda)**2)/(mevfm**5) nuCrdJ = CrdJ*((nufpi*nuLambda)**2)/(mevfm**5) nuCJ = CJ*((nufpi*nuLambda)**2)/(mevfm**5) nuCpV0 = CpV0*(nufpi**2)/(mevfm**3) nuCpV1 = CpV1*(nufpi**4)*nuLambda/(mevfm**6) End Subroutine calculate_natural_units !=============================================================================================== ! !=============================================================================================== Subroutine calculate_C_from_NM(E,K,SMASS,RHO,ASS,LASS,VMASS,sigma_NM) !-------------------------------------------------------------------------------- ! Calculates volume C-constants (and sigma) form NM properties ! Interface usage: ! hbzero,CK,kfconst,mpi,sigma ! aRhoRho,bRhoRho... ! hRho0Rho0,dhRho0Rho0... ! Crho(0),Crho(1),Cdrho(0),Cdrho(1),Ctau(0),Ctau(0) ! subroutine calculate_U_parameters ! ! input: E,K,SMASS,RHO,ASS,LASS,VMASS,sigma_NM(optional) ! output: Crho(0),Crho(1),Cdrho(0),Cdrho(1),Ctau(0),Ctau(0),sigma(optional) ! ! Options: ! When sigma_NM exists then 'sigma'=sigma_NM ! When sigma_NM does not exist then 'sigma' is defined from NM !-------------------------------------------------------------------------------- Implicit None Real(pr), Intent(in) :: E,K,SMASS,RHO,ASS,LASS,VMASS Real(pr), Intent(in), Optional :: sigma_NM Real(pr) :: aRho0Rho0,daRho0Rho0,ddaRho0Rho0,aRho1Rho1,daRho1Rho1,ddaRho1Rho1 Real(pr) :: aRho0Tau0,daRho0Tau0,ddaRho0Tau0,aRho1Tau1,daRho1Tau1,ddaRho1Tau1 Real(pr) :: u,tauc,rho2 Real(pr),Parameter :: c13=1.0_pr/3.0_pr,c23=2.0_pr/3.0_pr ! tauc=CK*RHO**c23; u=(kfconst/mpi)*RHO**c13; rho2=rho**2 ! Call calculate_U_parameters(RHO,RHO,tauc*RHO,tauc*RHO,0.0_pr,0.0_pr) ! aRho0Rho0=0.50_pr*(aRhoRho+bRhoRho)*mevfm aRho1Rho1=0.50_pr*(aRhoRho-bRhoRho)*mevfm aRho0Tau0=0.50_pr*(aRhoTau+bRhoTau)*mevfm aRho1Tau1=0.50_pr*(aRhoTau-bRhoTau)*mevfm daRho0Rho0=0.50_pr*(daRhoRho+dbRhoRho)*mevfm daRho1Rho1=0.50_pr*(daRhoRho-dbRhoRho)*mevfm daRho0Tau0=0.50_pr*(daRhoTau+dbRhoTau)*mevfm daRho1Tau1=0.50_pr*(daRhoTau-dbRhoTau)*mevfm ddaRho0Rho0=0.50_pr*(ddaRhoRho+ddbRhoRho)*mevfm ddaRho1Rho1=0.50_pr*(ddaRhoRho-ddbRhoRho)*mevfm ddaRho0Tau0=0.50_pr*(ddaRhoTau+ddbRhoTau)*mevfm ddaRho1Tau1=0.50_pr*(ddaRhoTau-ddbRhoTau)*mevfm ! ! set/calculate sigma If (Present(sigma_NM)) Then sigma=sigma_NM Else sigma=((1.0_pr/3.0_pr)*(-K+tauc*hbzero*(-3.0_pr+4.0_pr*SMASS)-9.0_pr*E+9.0_pr*RHO2*hRho0Rho0 & +21.0_pr*tauc*RHO2*hRho0Tau0+u*RHO*(daRho0Rho0+5.0_pr*tauc*daRho0Tau0 & +7.0_pr*RHO*dhRho0Rho0+11.0_pr*tauc*RHO*dhRho0Tau0+u*ddaRho0Rho0 & +u*tauc*ddaRho0Tau0+u*RHO*ddhRho0Rho0+u*tauc*RHO*ddhRho0Tau0))) & /(tauc*hbzero*(-3.0_pr+2.0_pr*SMASS)+3.0_pr*E+3.0_pr*RHO2*hRho0Rho0 & +3.0_pr*tauc*RHO2*hRho0Tau0+u*RHO*(daRho0Rho0+tauc*daRho0Tau0 & + RHO*dhRho0Rho0+tauc*RHO*dhRho0Tau0)) End If ! Crho(0)=(c13*(tauc*hbzero*(-3.0_pr+(2.0_pr-3.0_pr*sigma)*SMASS) & +3.0_pr*(1.0_pr+sigma)*E-3.0_pr*sigma*RHO*aRho0Rho0 & +3.0_pr*(1.0_pr-sigma)*RHO2*hRho0Rho0+3.0_pr*tauc*RHO2*hRho0Tau0 & +u*RHO*(daRho0Rho0+tauc*daRho0Tau0+RHO*dhRho0Rho0 & +tauc*RHO*dhRho0Tau0)))/(sigma*RHO) Cdrho(0)=(c13*RHO**(-1.0_pr-sigma)*(tauc*hbzero*(3.0_pr-2.0_pr*SMASS)& -3.0_pr*E-3.0_pr*RHO**2*hRho0Rho0-3.0_pr*tauc*RHO2*hRho0Tau0& -u*RHO*(daRho0Rho0+tauc*daRho0Tau0+RHO*dhRho0Rho0 & +tauc*RHO*dhRho0Tau0)))/sigma Ctau(0)=(hbzero*(SMASS-1.0_pr)-RHO*(aRho0Tau0+RHO*hRho0Tau0))/RHO ! Crho(1)=(27.0_pr*ASS*(1.0_pr+sigma)-9.0_pr*LASS & +5.0_pr*tauc*hbzero*(5.0_pr-6.0_pr*VMASS+3.0_pr*sigma*(-4.0_pr+3.0_pr*VMASS)) & +20.0_pr*tauc*(2.0_pr-3.0_pr*sigma)*RHO*aRho0Tau0 & +RHO*(-27.0_pr*sigma*aRho1Rho1+5.0_pr*tauc*(11.0_pr-12.0_pr*sigma)*RHO*hRho0Tau0 & -27.0_pr*(-1.0_pr+sigma)*RHO*hRho1Rho1+9.0_pr*tauc*(5.0_pr-3.0_pr*sigma)*RHO*hRho1Tau0 & +45.0_pr*tauc*RHO*hRho1Tau1+40.0_pr*tauc*Ctau(0)-60.0_pr*tauc*sigma*Ctau(0) & +5.0_pr*u*tauc*daRho0Tau0+9.0_pr*u*daRho1Rho1+15.0_pr*u*tauc*daRho1Tau1 & +5.0_pr*u*tauc*RHO*dhRho0Tau0+9.0_pr*u*RHO*dhRho1Rho1+9.0_pr*u*tauc*RHO*dhRho1Tau0 & +15.0_pr*u*tauc*RHO*dhRho1Tau1))/(27.0_pr*sigma*RHO) Cdrho(1)=-(RHO**(-1.0_pr-sigma)*(27.0_pr*ASS-9.0_pr*LASS & +5.0_pr*tauc*hbzero*(5.0_pr-6.0_pr*VMASS)+40.0_pr*tauc*RHO*aRho0Tau0 & +55.0_pr*tauc*RHO2*hRho0Tau0+27.0_pr*RHO**2*hRho1Rho1+45.0_pr*tauc*RHO2*hRho1Tau0 & +45.0_pr*tauc*RHO2*hRho1Tau1+40.0_pr*tauc*RHO*Ctau(0) +5.0_pr*u*tauc*RHO*daRho0Tau0 & +9.0_pr*u*RHO*daRho1Rho1+15.0_pr*u*tauc*RHO*daRho1Tau1 & +5.0_pr*u*tauc*RHO2*dhRho0Tau0+9.0_pr*u*RHO2*dhRho1Rho1 & +9.0_pr*u*tauc*RHO2*dhRho1Tau0 +15.0_pr*u*tauc*RHO2*dhRho1Tau1))/(27.0_pr*sigma) Ctau(1)=(hbzero-hbzero*VMASS+RHO*(aRho0Tau0-aRho1Tau1+RHO*hRho0Tau0-RHO*hRho1Tau1+Ctau(0)))/RHO ! End Subroutine calculate_C_from_NM !=============================================================================================== ! !=============================================================================================== Subroutine calculate_NM_properties() !-------------------------------------------------------------------------------- ! Calculates INM properties ! Interface usage: ! hbzero,CK,kfconst,mpi,sigma ! aRhoRho,bRhoRho... ! hRho0Rho0,dhRho0Rho0... ! Crho(0),Crho(1),Cdrho(0),Cdrho(1),Ctau(0),Ctau(0) ! E_NM,K_NM,SMASS_NM,RHO_NM,ASS_NM,LASS_NM,VMASS_NM,sigma,P_NM,KA_NM ! function find_NM_RHOC() ! input: Crho(0),Crho(1),Cdrho(0),Cdrho(1),Ctau(0),Ctau(0),sigma ! output: E_NM,K_NM,SMASS_NM,RHO_NM,ASS_NM,LASS_NM,VMASS_NM,sigma,P_NM,KA_NM ! Using: ! RHO_NM=find_NM_RHOC() !-------------------------------------------------------------------------------- Implicit None Real(pr) :: aRho0Rho0,daRho0Rho0,ddaRho0Rho0,aRho1Rho1,daRho1Rho1,ddaRho1Rho1 Real(pr) :: aRho0Tau0,daRho0Tau0,ddaRho0Tau0,aRho1Tau1,daRho1Tau1,ddaRho1Tau1 Real(pr) :: u,tauc,rho_NM2 Real(pr), Parameter :: c13=1.0_pr/3.0_pr,c23=2.0_pr/3.0_pr ! RHO_NM=find_NM_RHOC() ! aRho0Rho0=0.50_pr*(aRhoRho+bRhoRho)*mevfm aRho1Rho1=0.50_pr*(aRhoRho-bRhoRho)*mevfm aRho0Tau0=0.50_pr*(aRhoTau+bRhoTau)*mevfm aRho1Tau1=0.50_pr*(aRhoTau-bRhoTau)*mevfm daRho0Rho0=0.50_pr*(daRhoRho+dbRhoRho)*mevfm daRho1Rho1=0.50_pr*(daRhoRho-dbRhoRho)*mevfm daRho0Tau0=0.50_pr*(daRhoTau+dbRhoTau)*mevfm daRho1Tau1=0.50_pr*(daRhoTau-dbRhoTau)*mevfm ddaRho0Rho0=0.50_pr*(ddaRhoRho+ddbRhoRho)*mevfm ddaRho1Rho1=0.50_pr*(ddaRhoRho-ddbRhoRho)*mevfm ddaRho0Tau0=0.50_pr*(ddaRhoTau+ddbRhoTau)*mevfm ddaRho1Tau1=0.50_pr*(ddaRhoTau-ddbRhoTau)*mevfm tauc=CK*RHO_NM**c23; u=(kfconst/mpi)*RHO_NM**c13; rho_NM2=rho_NM**2 ! ! Symmetric Nuclear Matter E_NM=tauc*hbzero+RHO_NM*(aRho0Rho0+RHO_NM*hRho0Rho0+Crho(0)+RHO_NM**sigma*Cdrho(0)) & +tauc*RHO_NM*(aRho0Tau0+RHO_NM*hRho0Tau0+Ctau(0)) P_NM=c13*RHO_NM**2*((2.0_pr*tauc*hbzero)/RHO_NM+3.0_pr*aRho0Rho0+5.0_pr*tauc*aRho0Tau0 & +6.0_pr*RHO_NM*hRho0Rho0+8.0_pr*tauc*RHO_NM*hRho0Tau0+3.0_pr*Crho(0) & +3.0_pr*(1+sigma)*RHO_NM**sigma*Cdrho(0)+5.0_pr*tauc*Ctau(0)+u*daRho0Rho0 & +u*tauc*daRho0Tau0+u*RHO_NM*dhRho0Rho0+u*tauc*RHO_NM*dhRho0Tau0) SMASS_NM=1.0_pr+(RHO_NM*(aRho0Tau0+RHO_NM*hRho0Tau0+Ctau(0)))/hbzero K_NM=9.0_pr*sigma*(1+sigma)*RHO_NM**(1+sigma)*Cdrho(0) & +(-2.0_pr*tauc*hbzero+10.0_pr*tauc*RHO_NM*aRho0Tau0+18.0_pr*RHO_NM2*hRho0Rho0 & +40.0_pr*tauc*RHO_NM**2*hRho0Tau0+4.0_pr*u*RHO_NM*daRho0Rho0 & +RHO_NM*(10.0_pr*tauc*Ctau(0)+u*(8.0_pr*tauc*daRho0Tau0+u*ddaRho0Rho0 & +(10.0_pr*RHO_NM*dhRho0Rho0+14.0_pr*tauc*RHO_NM*dhRho0Tau0 & +(u*tauc*ddaRho0Tau0+u*RHO_NM*ddhRho0Rho0+u*tauc*RHO_NM*ddhRho0Tau0))))) ! ! Asymmetric Nuclear Matter ASS_NM=RHO_NM2*hRho1Rho1+RHO_NM*(aRho1Rho1+Crho(1)+RHO_NM**sigma*Cdrho(1)) & +(tauc*(5.0_pr*hbzero+RHO_NM*(5.0_pr*aRho0Tau0+15.0_pr*aRho1Tau1+5.0_pr*RHO_NM*hRho0Tau0 & +9.0_pr*RHO_NM*hRho1Tau0+5.0_pr*(3.0_pr*RHO_NM*hRho1Tau1+Ctau(0)+3.0_pr*Ctau(1)))))/9.0_pr VMASS_NM=(hbzero+RHO_NM*(aRho0Tau0-aRho1Tau1+RHO_NM*hRho0Tau0-RHO_NM*hRho1Tau1+Ctau(0)-Ctau(1)))/hbzero LASS_NM=6.0_pr*RHO_NM2*hRho1Rho1+3.0_pr*RHO_NM*(aRho1Rho1+Crho(1)+(1.0_pr+sigma)*RHO_NM**sigma*Cdrho(1)) & +u*RHO_NM*daRho1Rho1 +u*RHO_NM2*dhRho1Rho1 & +(tauc*(10.0_pr*hbzero+8.0_pr*RHO_NM2*(5.0_pr*hRho0Tau0+9.0_pr*hRho1Tau0+15.0_pr*hRho1Tau1) & +25.0_pr*RHO_NM*(aRho0Tau0+3.0_pr*aRho1Tau1+Ctau(0)+3*Ctau(1)) & +5.0_pr*u*RHO_NM*(daRho0Tau0+3.0_pr*daRho1Tau1) & +u*RHO_NM2*(5.0_pr*dhRho0Tau0+9.0_pr*dhRho1Tau0+15.0_pr*dhRho1Tau1)))/9.0_pr KA_NM=18.0_pr*RHO_NM2*hRho1Rho1+9.0_pr*sigma*(1.0_pr+sigma)*RHO_NM**(1.0_pr+sigma)*Cdrho(1) & +4.0_pr*u*RHO_NM*daRho1Rho1 +10.0_pr*u*RHO_NM2*dhRho1Rho1 & + u**2*RHO_NM*ddaRho1Rho1+u**2*RHO_NM2*ddhRho1Rho1 & +(tauc*(-10.0_pr*hbzero+40.0_pr*RHO_NM2*(5.0_pr*hRho0Tau0+9.0_pr*hRho1Tau0+15.0_pr*hRho1Tau1) & +50.0_pr*RHO_NM*(aRho0Tau0+3.0_pr*aRho1Tau1+Ctau(0)+3*Ctau(1)) & +40.0_pr*u*RHO_NM*(daRho0Tau0+3.0_pr*daRho1Tau1) & +14.0_pr*u*RHO_NM2*(5.0_pr*dhRho0Tau0+9.0_pr*dhRho1Tau0 & +15.0_pr*dhRho1Tau1)+5.0_pr*u**2*RHO_NM*(ddaRho0Tau0 & +3.0_pr*ddaRho1Tau1)+u**2*RHO_NM2*(5.0_pr*ddhRho0Tau0+9*ddhRho1Tau0+15*ddhRho1Tau1)))/9. ! End Subroutine calculate_NM_properties !=============================================================================================== ! !=============================================================================================== Real(pr) Function find_NM_RHOC() !-------------------------------------------------------------------------------- ! Search for the INM saturation density RHO_NM using the Secant Method !-------------------------------------------------------------------------------- Implicit None !Integer(pr) intent(out) :: ierr Integer(ipr) :: iter Real(pr) :: aRho0Rho0,daRho0Rho0,ddaRho0Rho0,aRho1Rho1,daRho1Rho1,ddaRho1Rho1 Real(pr) :: aRho0Tau0,daRho0Tau0,ddaRho0Tau0,aRho1Tau1,daRho1Tau1,ddaRho1Tau1 Real(pr) :: kfconstmpi,u,tauc Real(pr) :: rhom0,rhom,rhom2,w,w0,step,energy Real(pr),Parameter :: c13=1.0_pr/3.0_pr,c23=2.0_pr/3.0_pr ! kfconstmpi=kfconst/mpi; step=-0.0010_pr; iter=0 ! initial point rhom=0.170_pr; tauc=CK*rhom**c23; u=kfconstmpi*rhom**c13; rhom2=rhom**2 ! Call calculate_U_parameters(rhom,rhom,tauc*rhom,tauc*rhom,0.0_pr,0.0_pr) ! aRho0Rho0=0.50_pr*(aRhoRho+bRhoRho)*mevfm; daRho0Rho0=0.50_pr*(daRhoRho+dbRhoRho)*mevfm aRho0Tau0=0.50_pr*(aRhoTau+bRhoTau)*mevfm; daRho0Tau0=0.50_pr*(daRhoTau+dbRhoTau)*mevfm w0=c13*rhom2*((2.0_pr*tauc*hbzero)/rhom+3.0_pr*aRho0Rho0+5.0_pr*tauc*aRho0Tau0 & +6.0_pr*rhom*hRho0Rho0+8.0_pr*tauc*rhom*hRho0Tau0+3.0_pr*Crho(0) & +3.0_pr*(1.0_pr+sigma)*rhom**sigma*Cdrho(0)+5.0_pr*tauc*Ctau(0)+u*daRho0Rho0 & +u*tauc*daRho0Tau0+u*rhom*dhRho0Rho0+u*tauc*rhom*dhRho0Tau0) rhom0=rhom; rhom=rhom+step ! ! secant method Do While(Abs(step).Ge.eps*100.0_pr) iter=iter+1 tauc=CK*rhom**c23; u=kfconstmpi*rhom**c13; rhom2=rhom**2 ! Call calculate_U_parameters(rhom,rhom,tauc*rhom,tauc*rhom,0.0_pr,0.0_pr) ! aRho0Rho0=0.50_pr*(aRhoRho+bRhoRho)*mevfm; daRho0Rho0=0.50_pr*(daRhoRho+dbRhoRho)*mevfm aRho0Tau0=0.50_pr*(aRhoTau+bRhoTau)*mevfm; daRho0Tau0=0.50_pr*(daRhoTau+dbRhoTau)*mevfm w=c13*rhom2*((2.0_pr*tauc*hbzero)/rhom+3.0_pr*aRho0Rho0+5.0_pr*tauc*aRho0Tau0 & +6.0_pr*rhom*hRho0Rho0+8.0_pr*tauc*rhom*hRho0Tau0+3.0_pr*Crho(0) & +3.0_pr*(1.0_pr+sigma)*rhom**sigma*Cdrho(0)+5.0_pr*tauc*Ctau(0)+u*daRho0Rho0 & +u*tauc*daRho0Tau0+u*rhom*dhRho0Rho0+u*tauc*rhom*dhRho0Tau0) step=-w*(rhom-rhom0)/(w-w0) rhom0=rhom; w0=w; rhom=rhom+step If(iter.Gt.100) Stop 'STOP(In find_NM_RHOC)' !energy=tauc*hbzero+rhom*(aRho0Rho0+rhom*hRho0Rho0+Crho(0)+rhom**sigma*Cdrho(0)) & ! +tauc*rhom*(aRho0Tau0+rhom*hRho0Tau0+Ctau(0)) !Write(6,'(a,15(1pg12.4))') ' rhom0,rhom,step,e,w=',rhom0,rhom,step,energy,w End Do find_NM_RHOC=rhom End Function find_NM_RHOC !=============================================================================================== ! !=============================================================================================== Subroutine C_from_t() !-------------------------------------------------------------------------------- ! C- from (t,x)- !-------------------------------------------------------------------------------- Implicit None Crho(0) = 3.0_pr/8.0_pr * t0 Cdrho(0) = (1.0_pr/16.0_pr)* t3 Crho(1) = -(1.0_pr/4.0_pr) * t0*(0.50_pr+x0) Cdrho(1) = -(1.0_pr/24.0_pr)* t3*(0.50_pr+x3) Ctau(0) = (3.0_pr/16.0_pr)* t1+(1.0_pr/4.0_pr)*t2*(5.0_pr/4.0_pr+x2) Ctau(1) = -(1.0_pr/8.0_pr) * t1*(0.5+x1)+(1.0_pr/8.0_pr)*t2*(0.50_pr+x2) CrDr(0) = (1.0_pr/16.0_pr)* t2*(5.0_pr/4.0_pr+x2)-(9.0_pr/64.0_pr)*t1 CrDr(1) = (3.0_pr/32.0_pr)* t1*(0.5+x1)+(1.0_pr/32.0_pr)*t2*(0.50_pr+x2) CJ(0) = -(1.0_pr/16.0_pr)*(t1*(2.0_pr*x1-1.0_pr)+t2*(2.0_pr*x2+1)-5*te-15*to) CJ(1) = -(1.0_pr/16.0_pr)*(t2 -t1 + 5.0_pr*te -5.0_pr*to ) CrdJ(0) = -b4-(0.50_pr)*b4p CrdJ(1) = -0.50_pr*b4p End Subroutine C_from_t !=============================================================================================== ! !=============================================================================================== Subroutine t_from_C() !-------------------------------------------------------------------------------- ! (t,x)- from C- !-------------------------------------------------------------------------------- Implicit None t0 = (8.0_pr/3)*Crho(0) t1 = 4.0_pr/3.0_pr*(Ctau(0)-4.0_pr*CrDr(0)) t2 = 4.0_pr/3.0_pr*(3.0_pr*Ctau(0)-6.0_pr*Ctau(1)+4.0_pr*CrDr(0)-8.0_pr*CrDr(1)) t3 = 16.0_pr*Cdrho(0) x0 = -0.50_pr*(3.0_pr*Crho(1)/Crho(0)+1.0_pr) x1 = 2.0_pr*(-Ctau(0)-3.0_pr*Ctau(1)+4.0_pr*CrDr(0)+12.0_pr*CrDr(1))/t1/3.0_pr x2 = -2.0_pr*(3.0_pr*Ctau(0)-15.0_pr*Ctau(1)+4.0_pr*CrDr(0)-20.0_pr*CrDr(1))/t2/3.0_pr x3 = -0.50_pr*(3.0_pr*Cdrho(1)/Cdrho(0)+1.0_pr) b4 = CrdJ(1)-CrdJ(0) b4p = -2.0_pr*CrdJ(1) te = (4.0_pr/15.0_pr)*(3.0_pr*CJ(0)-9.0_pr*CJ(1)-4.0_pr*CrDr(0)+12.0_pr*CrDr(1)-2.0_pr*Ctau(0)+6.0_pr*Ctau(1)) to = (4.0_pr/15.0_pr)*(3.0_pr*CJ(0)+3.0_pr*CJ(1)+4.0_pr*CrDr(0)+4.0_pr*CrDr(1)) ! Set public variables t0_pub = t0; t1_pub = t1; t2_pub = t2; t3_pub = t3 x0_pub = x0; x1_pub = x1; x2_pub = x2; x3_pub = x3 b4_pub = b4; b4p_pub = b4p; te_pub = te; to_pub = to End Subroutine t_from_C !=============================================================================================== ! !=============================================================================================== Subroutine CHrho_from_NM() !-------------------------------------------------------------------------------- ! CHrho from NM, E_NM(Hartree)=CHrho*RHO_NM !-------------------------------------------------------------------------------- Implicit None Real(pr) :: z3=1.50_pr ! !!CHrho= & !!+h0mpi6c3NM*(A3_1/b3_1**z3+A3_2/b3_2**z3+A3_3/b3_3**z3+A3_4/b3_4**z3+A3_5/b3_5**z3) & !!+h0mpi6c1NM*(A1_1/b1_1**z3+A1_2/b1_2**z3+A1_3/b1_3**z3+A1_4/b1_4**z3+A1_5/b1_5**z3) CHrho = 0.0_pr ! End Subroutine CHrho_from_NM !=============================================================================================== ! !=============================================================================================== Elemental Function HartreeV00(u) !-------------------------------------------------------------------------------- ! HartreeV(u), E(Hartree)=(1/2)*Int[rho_0(r)*V(|r-r'|)*rho_0(r')] !-------------------------------------------------------------------------------- Implicit None Real(pr), Intent(in) :: u Real(pr) :: x2,HartreeV00 ! !!x2=(u*mpi)**2 ! !!HartreeV=h0mpi6c1*(Exp(-x2*b1_1)*A1_1+Exp(-x2*b1_2)*A1_2+Exp(-x2*b1_3)*A1_3+Exp(-x2*b1_4)*A1_4+Exp(-x2*b1_5)*A1_5)+& !!h0mpi6c3*(Exp(-x2*b3_1)*A3_1+Exp(-x2*b3_2)*A3_2+Exp(-x2*b3_3)*A3_3+Exp(-x2*b3_4)*A3_4+Exp(-x2*b3_5)*A3_5) ! HartreeV00=0.0_pr ! End Function HartreeV00 ! Elemental Function HartreeV01(u) !-------------------------------------------------------------------------------- ! HartreeV(u), E(Hartree)=(1/2)*Int[rho_0(r)*V(|r-r'|)*rho_1(r')] !-------------------------------------------------------------------------------- Implicit None Real(pr), Intent(in) :: u Real(pr) :: x2,HartreeV01 ! HartreeV01=0.0_pr ! End Function HartreeV01 ! Elemental Function HartreeV11(u) !-------------------------------------------------------------------------------- ! HartreeV(u), E(Hartree)=(1/2)*Int[rho_1(r)*V(|r-r'|)*rho_1(r')] !-------------------------------------------------------------------------------- Implicit None Real(pr), Intent(in) :: u Real(pr) :: x2,HartreeV11 ! HartreeV11=0.0_pr ! End Function HartreeV11 !=============================================================================================== ! !=============================================================================================== Elemental Function ThetaFunction2(u) !-------------------------------------------------------------------------------- ! ThetaFunction2(u)=0 or 1 when x2<2 or x2>2 !-------------------------------------------------------------------------------- Implicit None Real(pr), Intent(in) :: u Real(pr) :: x2,ThetaFunction2 ! x2=(u*mpi) ! ThetaFunction2=0.0_pr If(x2.Gt.2.0_pr) ThetaFunction2=1.0_pr ! End Function ThetaFunction2 !=============================================================================================== ! !=============================================================================================== Subroutine Make_Parameter_Free_Useful_Combinations() !-------------------------------------------------------------------------------- ! Make Useful combinations !-------------------------------------------------------------------------------- Implicit None ! If(dmeorder.Ge.0) Then ! mpi2=mpi**2 gA2=gA**2; gA4=gA2**2; gA6=gA2**3; fpi2=fpi**2; fpi4=fpi2**2; CHartree =mevfm*(3.0_pr*gA2)/(32.0_pr*fpi4*Pi**2) h0mpi6=197.30_pr*(mpi**6)*(3.0_pr*gA*gA)/(32.0_pr*fpi**4*Pi**2) h0mpi6c1=h0mpi6*c1; h0mpi6c3=h0mpi6*c3 ! h0mpi6NM=197.30_pr*(3.0_pr*(mpi**3)*gA2)/(64.0_pr*fpi**4*Sqrt(Pi)) h0mpi6c1NM=h0mpi6NM*c1; h0mpi6c3NM=h0mpi6NM*c3 ! A3_1=42.7132145164590_pr; A3_2=0.670441422115440_pr; A3_3=0.0525713896514650_pr; A3_4=0.0012545731701320_pr; A3_5=5.81008627207380_pr b3_1=3.0809379008590_pr; b3_2=0.905186811964580_pr; b3_3=0.474514509597610_pr; b3_4=0.228138177966090_pr; b3_5=1.66931540698090_pr; ! A1_1=2.5000830618386_pr; A1_2=0.619542286897850_pr; A1_3=0.169682589033730_pr; A1_4=0.0276112113725470_pr; A1_5=0.00108164458809540_pr b1_1=1.75854210706510_pr; b1_2=0.88882524524657_pr; b1_3=0.46377235143756_pr; b1_4=0.247665887704790_pr; b1_5=0.132222413002680_pr ! End If ! End Subroutine Make_Parameter_Free_Useful_Combinations !=============================================================================================== ! !=============================================================================================== Elemental Function Vexternal(t,x,y,z) ! Implicit None Integer(ipr), Intent(in) :: t !! isospin index: 0=isoscalar, 1=isovector Real(pr), Intent(in) :: x,y,z !! position in cartesian basis Real(pr) :: Vexternal ! Vexternal = 0.0_pr ! End Function Vexternal ! End Module UNEDF !================================================================================================================================== !#END UNEDF MODULE !================================================================================================================================== !#START HFBTHO MODULE !================================================================================================================================== Module HFBTHO Use HFBTHO_VERSION Use UNEDF ! ! Input for HFBiterations Integer(ipr) :: n00_INI,iLST_INI,inin_INI,icou_INI Integer(ipr) :: npr_INI(3),kindhfb_INI Integer(ipr) :: keyblo1_INI,keyblo2_INI,IDEBUG_INI Integer(ipr) :: ngh_INI,ngl_INI,nleg_INI,nstate_INI Real(pr) :: b0_INI,bz_INI,bp_INI,q_INI Character(30) :: skyrme_INI Real(pr) :: pwi_INI,V0n_INI,V0p_INI,cpv1_INI,epsi_INI Logical :: basis_HFODD_INI,Add_Pairing_INI,Print_HFBTHO_Namelist_INI,DO_FITT_INI ! Output for regression optimization Real(pr) :: efit_0 Real(pr), Dimension(0:1) :: efit_rhorho,efit_rhorhoD,efit_rhotau,efit_rhoDrho Real(pr), Dimension(0:1) :: efit_rhonablaJ,efit_JJ,efitV0,dfitV0,efV_0 ! serial output (1:on/0:off) Integer(ipr) :: IDEBUG Logical :: DO_FITT ! For loop over used particle types. For normal nuclei min=1, max=2. For n droplets min=max=1. Integer(ipr) :: itmin,itmax,irestart ! Frequent Constants Real(pr) :: PI,ffdef3,ffdef4,ffdef5,ffdef6,ffdef7 ! Single constants Real(pr) :: bet,beta0,q,bp,bpp,bz,hom,hb0,b0,etot,coex,cex,ty20,vin,rin,ain, & qin,pwi,si,siold,epsi,xmix,xmix0,xmax,alst,clst,sklst,alphi,amas, & skass,varmas,v0ws,akv,hqc,amu,amn,r0,r00,r02,r04,decay,rmm3,amm3, & bmm3,cmm3,chargee2,EBASECUT,rho_c,cdef,b2_0,b4_0 Integer(ipr) :: lin,lwin,lwou,lplo,lwel,lres,icstr,icou,ncut,iLST1,iLST, & maxi,iiter,inin,nzm,nrm,icacou,iqrpa,icacoupj,icahartree,nlm, & nb,nt,n00,itass,kindhfb,iappend,iError_in_HO,iError_in_THO, & ierest,esu,nstate Integer(ipr), Parameter :: n00max=50 ! Results Integer(ipr), Parameter :: ieresu=50,ieresl=20,ieresj=50,ieresbl=6 Integer(ipr), Parameter :: ieres=ieresu+ieresl+ieresj+ieresbl Real(pr) :: eres(ieres) Character(13) :: ereslbl(2) Character(2) :: nucname Real(pr) :: eresu(ieresu),eresl(ieresl),eresbl(ieresbl),eresj(ieresj) Character(13) :: hlabels(ieres+3) ! Common small arrays Real(pr) :: alast(2),ala(2),ala1(2),tz(2),ass(2),drhoi(2),del(2),vso(2),r0v(2) & ,av(2),rso(2),aso(2),Sumnz(2),Dispersion(2),v2min(2),v2minv(2),rms(3),ept(3),q2(3) & ,Dnfactor(3),varmasnz(2),pjmassnz(2) Integer(ipr) :: npr(3),inz(2),ldel(2),nk(2),itbl(2),kbl(2),tpar(2),ipbl(2),nbl(2),ibbl(2) & ,klmax(2),inner(2),iasswrong(3),lcc ! Lipkin-Nogami Real(pr) :: ala2(2),etr(3),ssln(3,2),Geff(2) ! Blocking Real(pr) :: pwiblo=2.0_pr, eqpmin(2)=0.0_pr Integer(ipr) :: bloall; Parameter(bloall=200) Integer(ipr), Dimension(0:bloall,2) :: bloblo,blo123=0,blok1k2=0 Real(pr), Dimension(0:bloall,2) :: bloqpdif Integer(ipr) :: iparenti(2),keyblo(3),nkblo_INI(2,5),nkblo(2,5)=0 Integer(ipr) :: blocross(2),blomax(2),blo123d(2),blok1k2d(2),blocanon(2) ! manualBlocking Integer(ipr):: manualBlocking=0 ! Logical and character variables Character(1) :: tq,tp(2),tl(0:20),tis(2) Character(30) :: skyrme Character(8) :: tit(2) Character(7) :: protn(2) Data protn/'neutron','proton '/ ! Allocatable arrays Character(13), Allocatable :: tb(:) Character(25), Allocatable :: txb(:) Real(pr), Allocatable, Target :: rk(:,:),ak(:,:),hh0(:,:),de0(:,:) & ,ddc(:,:,:),ddc1(:,:,:),qh(:,:),qh1(:,:),ql(:,:,:),ql1(:,:,:) & ,ek(:,:),dk(:,:),vk(:,:),vk1(:,:),uk(:,:),hfb1(:,:),vkmax(:,:) Real(pr), Allocatable :: fdsx(:),fdsy(:),fdsy1(:),fdsy2(:),fdsy3(:),fspb0(:) & ,fspc0(:),fspd0(:),fspb1(:),fspc1(:),fspd1(:),fspb2(:),fspc2(:),fspd2(:),fspb3(:) & ,fspc3(:),fspd3(:),fak(:),fi(:),sq(:),sqi(:),wf(:),wfi(:),rkass(:,:) Integer(ipr), Allocatable :: id(:),ia(:),ikb(:),ipb(:),nz(:),nr(:),nl(:),ns(:),npar(:) & ,ka(:,:),kd(:,:),numax(:,:),iv(:), lcanon(:,:) Real(pr), Allocatable :: AN(:),ANK(:),PFIU(:),PFID(:) Real(pr), Allocatable :: FIU(:),FID(:),FIUR(:),FIDR(:) Real(pr), Allocatable :: FIUD2N(:),FIDD2N(:),FIUZ(:),FIDZ(:) ! constraints Integer(ipr), Parameter :: lambdaMax=8 Integer(ipr) :: numberCons Integer(ipr), Allocatable :: multLambda(:) Real(pr), Dimension(0:8,1:3) :: qmoment Real(pr), Allocatable :: q_units(:),multLag(:),multRequested(:) Real(pr), Allocatable :: multMatElems(:) ! Temperature Logical :: switch_on_temperature Real(pr) :: temper Real(pr), Dimension(3) :: entropy Real(pr), Allocatable, Target :: fn_T(:),fp_T(:) ! optimization arrays Real(pr), Allocatable :: QHLA_opt(:,:),FI1R_opt(:,:),FI1Z_opt(:,:),FI2D_opt(:,:),y_opt(:) ! Arrays depending on mesh points Integer(ipr) :: ngh,ngl,nleg,nghl,nbx,ntx,nzx,nrx,nlx,ndx,ndx2,ndxs,nqx Integer(ipr) :: nhfbqx,nb2x,nhfbx,nkx,nzrlx,iqqmax Real(pr), Allocatable :: xh(:),wh(:),xl(:),sxl(:),wl(:),xleg(:),wleg(:),vc(:,:) Real(pr), Allocatable :: vhbn(:),vn(:),vrn(:),vzn(:),vdn(:),vsn(:),dvn(:) Real(pr), Allocatable :: vhbp(:),vp(:),vrp(:),vzp(:),vdp(:),vsp(:),dvp(:) Real(pr), Allocatable :: vSZFIn(:),vSFIZn(:),vSRFIn(:),vSFIRn(:) Real(pr), Allocatable :: vSZFIp(:),vSFIZp(:),vSRFIp(:),vSFIRp(:) Real(pr), Allocatable, Target :: aka(:,:),ro(:,:),tau(:,:),dro(:,:),dj(:,:) & ,SZFI(:,:),SFIZ(:,:),SRFI(:,:),SFIR(:,:),NABLAR(:,:),NABLAZ(:,:) Real(pr), Allocatable :: fl(:),fli(:),fh(:),fd(:),fp1(:),fp2(:),fp3(:),fp4(:),fp5(:),fp6(:) & ,fs1(:),fs2(:),fs3(:),fs4(:),fs5(:),fs6(:),wdcor(:),wdcori(:),cou(:) Real(pr), Allocatable :: vDHartree(:,:),vhart00(:,:),vhart01(:,:),vhart11(:,:) ! PAV Projection Integer(ipr) :: keypj,ilpj,ilpj2,ilnqx,ilnghl Real(pr) :: rehfbcan,ehfb,retotpj,depnp,iproj,npr1pj,npr2pj Complex(pr) :: onei=(0.0_pr,1.0_pr) Complex(pr), Allocatable, Target :: phypj(:),sinphy(:),exp1iphy(:) & ,exp1iphym(:),exp2iphy(:),exp2iphym(:),coupj(:,:),ropj(:,:,:) & ,taupj(:,:,:),dropj(:,:,:),djpj(:,:,:),akapj(:,:,:),pjk(:,:) & ,SZFIpj(:,:,:),SFIZpj(:,:,:),SRFIpj(:,:,:),SFIRpj(:,:,:),epj(:,:) & ,ddepj(:,:,:),cpj(:,:,:),ypj(:,:,:),rpj(:,:,:) Real(pr) :: polem(2),polep(2) ! CMC Integer(ipr) :: ICMinput Real(pr) :: ECMHFB(3),ECMPAV(3) ! CRC Integer(ipr) :: ICRinput Real(pr) :: DEROT(3),SQUJ(3),CRAN(3),ERIGHFB(3) ! hfbdiagonal Real(pr), Allocatable :: erhfb(:),drhfb(:),erhfb1(:),drhfb1(:) Real(pr), Allocatable :: hfb(:,:),zhfb(:),evvk(:),hfbcan(:,:),evvkcan(:) ! Jason: def derived types Type :: ptr_to_2darray Real(pr), Dimension(:,:),Allocatable :: arr End Type ptr_to_2darray Type :: ptr_to_array Real(pr), Dimension(:),Allocatable :: arr End Type ptr_to_array Type :: ptr_to_iarray Integer(ipr), Dimension(:),Allocatable :: arr End Type ptr_to_iarray ! Jason: use derived types Type(ptr_to_2darray), Allocatable :: allhfb(:) Type(ptr_to_array), Allocatable :: allevvk(:),allalwork(:) Type(ptr_to_iarray), Allocatable :: alllwork(:),allISUPPZ(:) Integer(ipr), Allocatable :: allibro(:),allIALWORK(:),allILWORK(:) Integer(ipr) :: oldnb Real(pr) :: cutoff_tol=1.d-6 ! Broyden Character(1) :: bbroyden Integer(ipr) :: nbroyden=7 Real(pr) :: alphamix=0.70_pr Integer(ipr) :: nhhdim,nhhdim2,nhhdim3,nhhdim4,ialwork,ilwork Real(pr), Allocatable, Target :: brout(:),brin(:) Real(pr), Allocatable :: alwork(:) Integer(ipr), Allocatable :: lwork(:) ! cm Real(pr) :: facECM=1.0_pr ! new keys Logical :: set_pairing,basis_HFODD,Parity,Parity_INI Logical :: Print_Screen=.False. Logical :: Add_Pairing,Print_HFBTHO_Namelist Integer(ipr) :: MAX_ITER_INI,keypj_INI,iproj_INI,npr1pj_INI,npr2pj_INI ! Eqp U,V Integer(ipr) :: nuv,nqp Real(pr), Allocatable, Target :: RVqpN(:),RVqpP(:),RUqpN(:),RUqpP(:),REqpN(:),REqpP(:) Integer(ipr), Allocatable, Target :: KpwiN(:),KpwiP(:),KqpN(:),KqpP(:) ! error indicator Integer(ipr) :: ierror_flag=0 Character(60) :: ierror_info(0:10) Character(30) :: welfile_INI ! Namelists Logical :: add_initial_pairing, set_temperature, compatibility_HFODD, force_parity, & user_pairing Integer(ipr) :: number_of_shells, proton_number, neutron_number, type_of_calculation, & number_iterations, type_of_coulomb, restart_file, projection_is_on, & gauge_points, delta_Z, delta_N, switch_to_THO, number_Gauss, & number_Laguerre, number_Legendre, number_states, print_time Integer(ipr) :: proton_blocking(1:5), neutron_blocking(1:5), lambda_values(1:lambdaMax), & lambda_active(1:lambdaMax) Real(pr) :: oscillator_length, basis_deformation, accuracy, temperature, & vpair_n, vpair_p, pairing_cutoff, pairing_feature Real(pr) :: expectation_values(1:lambdaMax) Character(Len=30) :: functional !Namelist /HFBTHO_GENERAL/ number_of_shells,oscillator_length, basis_deformation, & ! proton_number,neutron_number,type_of_calculation !Namelist /HFBTHO_ITERATIONS/ number_iterations, accuracy, restart_file !Namelist /HFBTHO_FUNCTIONAL/ functional, add_initial_pairing, type_of_coulomb !Namelist /HFBTHO_PAIRING/ user_pairing, vpair_n, vpair_p, pairing_cutoff, pairing_feature !Namelist /HFBTHO_CONSTRAINTS/ lambda_values, lambda_active, expectation_values !Namelist /HFBTHO_BLOCKING/ proton_blocking, neutron_blocking !Namelist /HFBTHO_PROJECTION/ switch_to_THO,projection_is_on,gauge_points,delta_Z,delta_N !Namelist /HFBTHO_TEMPERATURE/ set_temperature, temperature !Namelist /HFBTHO_DEBUG/ number_Gauss, number_Laguerre, number_Legendre, & ! compatibility_HFODD, number_states, force_parity, print_time ! End Module HFBTHO !================================================================================================================================== !#END HFBTHO MODULE !================================================================================================================================== !#START HFBTHO_gauss !================================================================================================================================== Module HFBTHO_gauss Use HFBTHO_utilities Use HFBTHO Implicit None Contains Subroutine gausspoints !--------------------------------------------------------------------- ! The routine determines the points and weights for Gauss quadratures ! in the cases of Gauss-Legendre, -Laguerre and -Hermite formulas. !--------------------------------------------------------------------- Implicit None Real(pr):: al,be,sparity Real(pr), Allocatable :: endpts(:),b(:),t(:),w(:) Integer(ipr) :: N,i,j,KINDI,kpts,nparity ! al=0.0_pr; be=0.0_pr; kpts=0 ! !-------------------------------------------------------------------- !------------------>> Gauss-Hermite (positive nodes) <<-------------- !-------------------------------------------------------------------- If(Parity) Then KINDI=4; N=2*ngh ! Parity conserved nparity=ngh; sparity=two Else KINDI=4; N=ngh ! Parity not conserved nparity=0; sparity=one End If Allocate(endpts(2)); Allocate(b(N),t(N),w(N)) Call Gaussq(KINDI,N,al,be,kpts,endpts,b,t,w) If(ierror_flag.Ne.0) Return Do i=nparity+1,N j=i-nparity xh(j)=t(i) ! Build in the Gaussian weight function into the weights wh wh(j)=sparity*Exp(xh(j)*xh(j)+Log(w(i))) End Do Deallocate(endpts,b,t,w) !-------------------------------------------------------------------- !---------------------------->> Gauss-Laguerre <<--------------------| !-------------------------------------------------------------------- KINDI=6; N=ngl Allocate(endpts(2)); Allocate(b(N),t(N),w(N)) Call Gaussq(KINDI,N,al,be,kpts,endpts,b,t,w) If(ierror_flag.Ne.0) Return Do j=1,ngl xl(j)=t(j) ! Build in the exponential weight function into the weights wl wl(j)=Exp(xl(j)+Log(w(j))) sxl(j)=Sqrt(xl(j)) End Do Deallocate(endpts,b,t,w) !-------------------------------------------------------------------- !----------------->> Gauss-Legendre (positive nodes) <<-------------- !-------------------------------------------------------------------- If(nleg.Gt.0) Then KINDI=1; N=2*nleg Allocate(endpts(2)); Allocate(b(N),t(N),w(N)) Call Gaussq(KINDI,N,al,be,kpts,endpts,b,t,w) If(ierror_flag.Ne.0) Return Do j=1,nleg i=nleg+j xleg(j)=t(i); wleg(j)=w(i) End Do Deallocate(endpts,b,t,w) End If ! End Subroutine gausspoints !======================================================================= ! !======================================================================= Subroutine Gaussq(kindi,n,alpha,beta,kpts,endpts,b,t,w) Implicit None Integer(ipr) :: N,kindi Real(pr):: alpha,beta,MUZERO,GAM,T1 Integer(ipr) :: j1,J2,kpts,ierr Real(pr):: b(n),t(n),w(n),endpts(2) !-------------------------------------------------------------------- ! This set of routines computes the nodes t(j) and weights w(j) for ! Gaussian-type quadrature rules with pre-assigned nodes. These are ! used when one wishes to approximate ! ! integral (from a to b) f(x) w(x) dx ! ! n ! by sum w f(t ) ! j=1 j j ! ! (note w(x) and w(j) have no connection with each other). Here w(x) ! is one of six possible non-negative weight functions (listed below), ! and f(x) is the function to be integrated. Gaussian quadrature is ! particularly useful on infinite intervals (with appropriate weight ! functions), since then other techniques often fail. Associated with ! each weight function w(x) is a set of orthogonal polynomials. The ! nodes t(j) are just the zeroes of the proper n-th degree polynomial. ! ! inputs (all real numbers are in double precision) ! kindi ..: an integer between 1 and 6 giving the type of ! quadrature rule: ! 1: Legendre quadrature, w(x) = 1 on [-1, 1] ! 2: Chebyshev quadrature of the first kind ! w(x) = 1/sqrt(1 - x*x) on [-1, +1] ! 3: Chebyshev quadrature of the second kind ! w(x) = sqrt(1 - x*x) on p-1, 1] ! 4: Hermite quadrature, w(x) = exp(-x*x) on ! ]-infinity, +infinity[ ! 5: Jacobi quadrature, w(x) = (1-x)**alpha * (1+x)** ! beta on [-1, 1], alpha, beta > -1. ! note: kind=2 and 3 are a special case of this. ! 6: generalized Laguerre quadrature, w(x) = exp(-x)* ! x**alpha on [0, +infinity[, alpha > -1 ! n .....: the number of points used for the quadrature rule ! alpha .: real parameter used only for Gauss-Jacobi and Gauss- ! Laguerre quadrature (otherwise use 0.d0). ! beta ..: real parameter used only for Gauss-Jacobi quadrature ! (otherwise use 0.d0) ! kpts ..: (integer) normally 0, unless the left or right end- ! point (or both) of the interval is required to be a ! node (this is called Gauss-Radau or Gauss-Lobatto ! quadrature). Then kpts is the number of fixed ! endpoints (1 or 2). ! endpts : real array of length 2. Contains the values of any ! fixed endpoints, if kpts = 1 or 2. ! b .....: real scratch array of length n ! ! outputs (both double precision arrays of length n) ! t .....: the desired nodes. ! w .....: the desired weights w(j). ! ! NOTE: Underflow may sometimes occur, but is harmless. ! ! Adapted from GO library at www.netlib.org !-------------------------------------------------------------------- ! Call Class(kindi,n,alpha,beta,b,t,muzero) ! If(KPTS.Eq.0) Then W=0.0_pr; W(1)=1._pr Call GBTQL2(N,T,B,W,IERR) W=MUZERO*W*W Return End If If(KPTS.Eq.2) Then GAM=GBSLVE(ENDPTS(1),N,T,B) T1=((ENDPTS(1)-ENDPTS(2))/(GBSLVE(ENDPTS(2),N,T,B)-GAM)) B(N-1)=Sqrt(T1) T(N)=ENDPTS(1)+GAM*T1 W=0.0_pr; W(1)=1._pr Call GBTQL2(N,T,B,W,IERR) W=MUZERO*W*W Return End If T(N)=GBSLVE(ENDPTS(1),N,T,B)*B(N-1)**2+ENDPTS(1) W=0.0_pr; W(1)=1._pr Call GBTQL2(N,T,B,W,IERR) W=MUZERO*W*W End Subroutine Gaussq !======================================================================= ! !======================================================================= Real(pr) Function GBSLVE(SHIFT,N,A,B) Implicit None Integer(ipr) :: N,NM1,i Real(pr) :: ALPHA,SHIFT,A(N),B(N) ALPHA=A(1)-SHIFT NM1=N-1 Do I=2,NM1 ALPHA=A(I)-SHIFT-B(I-1)**2/ALPHA End Do GBSLVE=1.0_pr/ALPHA End Function GBSLVE !======================================================================= ! !======================================================================= Subroutine Class(kindi,N,ALPHA,BETA,B,A,MUZERO) Implicit None Integer(ipr) :: N,kindi,i,NM1 Real(pr) :: MUZERO,ALPHA,BETA,A(N),B(N) Real(pr) :: PI,ABI,DI20,AB,A2B2,FI Data PI / 3.1415926535897930_pr / !-------------------------------------------------------------------- ! This procedure supplies the coefficients a(j), b(j) of the ! recurrence relation ! ! b p (x) = (x - a ) p (x) - b p (x) ! j j j j-1 j-1 j-2 ! ! for the various classical (normalized) orthogonal polynomials, ! and the zero-th moment ! ! muzero = integral w(x) dx ! ! of the given polynomial's weight function w(x). Since the ! polynomials are orthonormalized, the tridiagonal matrix is ! guaranteed to be symmetric. ! ! The input parameter alpha is used only for Laguerre and Jacobi ! polynomials, and the parameter beta is used only for Jacobi ! polynomials. The Laguerre and Jacobi polynomials require the Gamma ! function. ! ! Adapted from GO library at www.netlib.org !-------------------------------------------------------------------- NM1=N-1 Select Case (kindi) Case (1) ! Legendre polynomials MUZERO=2.0_pr Do I=1,NM1 A(I)=0.0_pr ABI=Real(I,Kind=pr) B(I)=ABI/Sqrt(4.0_pr*ABI*ABI-1.0_pr) End Do A(N)=0.0_pr Case (2) ! Chebyshev polynomials of the first kind MUZERO=PI Do I=1,NM1 A(I)=0.0_pr B(I)=0.50_pr End Do B(1)=Sqrt(0.50_pr) A(N)=0.0_pr Case (3) ! Chebyshev polynomials of the second kind MUZERO=PI/2.0_pr Do I=1,NM1 A(I)=0.0_pr B(I)=0.50_pr End Do A(N)=0.0_pr Case (4) ! Hermite polynomials MUZERO=Sqrt(PI) Do I=1,NM1 A(I)=0.0_pr DI20=I/2.0_pr B(I)=Sqrt(DI20) End Do A(N)=0.0_pr Case (5) ! Jacobi polynomials AB=ALPHA+BETA ABI=2.0_pr+AB MUZERO=2.0_pr**(AB+1.0_pr)*pr_gamma(ALPHA+1.0_pr)*pr_gamma(BETA+1.0_pr)/pr_gamma(ABI) A(1)=(BETA-ALPHA)/ABI B(1)=Sqrt(4.0_pr*(1.0_pr+ALPHA)*(1.0_pr+BETA)/((ABI+1.0_pr)*ABI*ABI)) A2B2=BETA*BETA-ALPHA*ALPHA Do I=2,NM1 ABI=2.0_pr*I+AB A(I)=A2B2/((ABI-2.0_pr)*ABI) FI=I B(I)=Sqrt(4.0_pr*FI*(FI+ALPHA)*(FI+BETA)*(FI+AB)/((ABI*ABI-1.0_pr)*ABI*ABI)) End Do ABI=2.0_pr*N+AB A(N)=A2B2/((ABI-2.0_pr)*ABI) Case (6) ! Laguerre polynomials MUZERO=pr_gamma(ALPHA+1.0_pr) Do I=1,NM1 FI=I A(I)=2.0_pr*FI-1.0_pr+ALPHA B(I)=Sqrt(FI*(FI+ALPHA)) End Do A(N)=2.0_pr*N-1.0_pr+ALPHA Case default End Select End Subroutine Class !======================================================================= ! !======================================================================= Subroutine GBTQL2(N,D,E,Z,IERR) Implicit None Integer(ipr) :: N,IERR Real(pr) :: D(N),E(N),Z(N) Integer(ipr) :: I,J,K,L,M,II,MML Real(pr) :: MACHEP,P,G,R,S,C,F,B !MACHEP=16.0_pr**(-14) MACHEP=epsilon(1.0_pr) IERR=0 If(N.Eq.1) Return E(N)=0.0_pr Do L= 1,N J=0 Do Do M=L,N If(M .Eq. N) Exit If(Abs(E(M)) .Le. MACHEP*(Abs(D(M))+Abs(D(M+1)))) Exit Continue End Do P=D(L) If(M .Eq. L) Exit If(J .Eq. 30) Then IERR=L Return End If J=J+1 G=(D(L+1)-P) / (2.0_pr*E(L)) R=Sqrt(G*G+1.0_pr) G=D(M) - P + E(L)/(G+Sign(R,G)) S=1.0_pr C=1.0_pr P=0.0_pr MML=M-L Do II=1, MML I=M-II F=S*E(I) B=C*E(I) If(Abs(F).Ge.Abs(G)) Then C=G/F R=Sqrt(C*C+1.0_pr) E(I+1)=F*R S=1.0_pr/R C=C*S Else S=F/G R=Sqrt(S*S+1.0_pr) E(I+1)=G*R C=1.0_pr/R S=S*C End If G=D(I+1)-P R=(D(I)-G)*S + 2.0_pr*C*B P=S*R D(I+1)=G+P G=C*R - B F=Z(I+1) Z(I+1)=S*Z(I) + C*F Z(I)=C*Z(I) - S*F End Do D(L)=D(L)-P E(L)=G E(M)=0.0_pr End Do End Do Do II=2, N I=II-1 K=I P=D(I) Do J=II,N If(D(J) .Ge. P) Cycle K=J P=D(J) End Do If(K .Eq. I) Cycle D(K)=D(I) D(I)=P P=Z(I) Z(I)=Z(K) Z(K)=P End Do End Subroutine GBTQL2 !======================================================================= ! !======================================================================= Real(pr) Function pr_gamma(x) !--------------------------------------------------------------------- ! pr_gamma evaluates Gamma(X) for a real argument. ! ! Discussion: ! This function was originally named DGAMMA. However, a number of ! Fortran compilers now include a library function of this name. To ! avoid conflicts, this function was renamed pr_gamma. ! ! This routine calculates the GAMMA function for a real argument X. ! Computation is based on an algorithm outlined in reference 1. ! The program uses rational functions that approximate the GAMMA ! function to at least 20 significant decimal digits. Coefficients ! for the approximation over the interval (1,2) are unpublished. ! Those for the approximation for 12 <= X are from reference 2. ! ! Licensing: ! This code is distributed under the GNU LGPL license. ! ! Modified: ! 18 January 2008 ! ! Author: ! Original FORTRAN77 version by William Cody, Laura Stoltz. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! William Cody, ! An Overview of Software Development for Special Functions, ! in Numerical Analysis Dundee, 1975, ! edited by GA Watson, ! Lecture Notes in Mathematics 506, ! Springer, 1976. ! John Hart, Ward Cheney, Charles Lawson, Hans Maehly, ! Charles Mesztenyi, John Rice, Henry Thatcher, Christoph Witzgall, ! Computer Approximations, ! Wiley, 1968, ! LC: QA297.C64. ! ! Parameters: ! Input, real ( kind = 8 ) X, the argument of the function. ! Output, real ( kind = 8 ) R8_GAMMA, the value of the function. !--------------------------------------------------------------------- Implicit None ! ! Coefficients for minimax approximation over (12, INF). Logical :: parity Integer(ipr) :: i,n Real(pr), Dimension(7) :: c = (/ -1.910444077728000000000D-03, & 8.417138778129500000000000D-04,-5.952379913043012000000D-04, & 7.936507935003502480000000D-04,-2.777777777777681622553D-03, & 8.333333333333333331554247D-02, 5.708383526100000000000D-03 /) Real(pr) :: eps,fact,pi,res,sqrtpi,sum,x,xbig,xden,xinf,xminin,xnum,y,y1,ysq,z Real(pr) :: p(8),q(8) ! ! Mathematical constants Data sqrtpi /0.9189385332046727417803297D+00/ Data pi /3.1415926535897932384626434D+00/ ! ! Numerator and denominator coefficients for rational minimax ! approximation over (1,2). Data p / -1.71618513886549492533811D+00, 2.47656508055759199108314D+01, & -3.79804256470945635097577D+02, 6.29331155312818442661052D+02, & 8.66966202790413211295064D+02, -3.14512729688483675254357D+04, & -3.61444134186911729807069D+04, 6.64561438202405440627855D+04 / Data q / -3.08402300119738975254353D+01, 3.15350626979604161529144D+02, & -1.01515636749021914166146D+03, -3.10777167157231109440444D+03, & 2.25381184209801510330112D+04, 4.75584627752788110767815D+03, & -1.34659959864969306392456D+05, -1.15132259675553483497211D+05 / parity = .False.; fact = one; n = 0; y = x xbig = 171.624D+00 xminin = Tiny(1.0_pr); eps = Epsilon(1.0_pr) ; xinf = Huge(1.0_pr) ! ! Argument is negative. If(y<=zero) Then y = - x y1 = Aint ( y ) res = y - y1 If(res/=zero) Then If(y1/=Aint(y1*half)*two) Then parity = .True. End If fact = - pi / Sin(pi*res) y = y + one Else res = xinf pr_gamma = res Return End If End If ! ! Argument is positive. if (y < eps) Then ! ! Argument < EPS. If(xminin <= y) Then res = one / y Else res = xinf pr_gamma = res Return End If Else If(yho, #0->tho ! ! In this way: ! (1) \delta \rho divided by j^2 is: ! dro = (cz*fs1+cr*fs2+fs3)*qhab*qlab ! + fs1*qha1b1*qlab ! + fs2*qhab*qla1b1/(4.*v**2) ! + fs4*(qha1b+qhab1)*(qla1b+qlab1)/(2.*v) ! + fs5*(qha1b+qhab1)*qlab ! + fs6*qhab*(qla1b+qlab1)/(2.*v) ! with ! cr = 1./4. - (nr_a+nr_b+m+1)/(2.*v) + (m/(2.*v))**2 ! cz = u*u - (nz_a+nz_b+1) ! (2) the first (r,z) derivatives are: ! fi'_z = fp1*(qh*ql) + fp2*(qh1*ql) + fp3*(qh*ql1)/(2.*v) ! -> HO -> qh1*ql/bpz ! fi'_r = fp4*(qh*ql) + fp5*(qh1*ql) + fp6*(qh*ql1)/(2.*v) ! -> HO -> qh*ql1/Sqrt(v)/bp !-------------------------------------------------------------------------- Use HFBTHO Implicit None Logical :: lpr Integer(ipr), Save :: i,il,ih,ihli,iw,key0=0,key1=1 Real(pr), Save :: bri,bri2,bzi,bzi2,wv1,u,qq,f,f1,f2,f3,rhoi,fd1,fd2, & fd12,fdd,r,r2,r3,r4,r5,r6,rr,rr2,rr4,zz,zz2,drr1,drr2,drz1, & drz2,drr12,drz12,g,g1,g2,g3,gg,gg1,gg2,g1g1,uz1,ur1,vz1,vr1,& uz2,ur2,vz2,vr2,ur12,vr12,uz12,vz12 ! bri= one/bp; bri2= bri*bri; bzi= one/bz; bzi2= bzi*bzi Do il=1,ngl wv1 = xl(il) Do ih=1,ngh ihli = ih+(il-1)*ngh u = xh(ih); qq = Sqrt(u*u+wv1) If(ilst1.Eq.0) Then ! ho-case r = qq; f = r; f1 = one; f2 = zero; f3 = zero Else ! tho-case: initial run If(ih*il.Eq.1.And.ilst.Lt.0) & Call thofun(key0,g,f,f1,f2,f3,g1,.True.,.False.) If(iasswrong(3).ne.0) then ! reinforce ho results r = qq; f = r; f1 = one; f2 = zero; f3 = zero else ! tho-case: f(r)=qq,f'(r),f''(r),f'''(r), r=Invers_f(r) Call thofun(key1,qq,f,f1,f2,f3,r,.False.,.False.) End If End If ! Jacobian calculations r2= r*r; r3= r2*r; r4= r2*r2 ;r5= r3*r2 ;r6= r3*r3 ! fdd=(f(r)^2 f'(r)/r^2)^(1/2),fd1=fdd'/fdd, fd2=fdd''/fdd fd1 = f1/f - one/r + half*f2/f1 fdd = f*Sqrt(f1)/r fd2 = two*(f2/f-fd1/r) - (f2/f1)**2/four + half*f3/f1 fd12 = fd1**2 ! g=(f/r)-derivatives g = f/r; g1 =-(f - f1*r)/r2 g2 = (two*(f - f1*r) + f2*r2)/r3 g3 = (six*(f1*r - f) - three*f2*r2 + f3*r3)/r4 ! g4 = (24.0d0*(f-f1*r+half*f2*r2)-four*f3*r3+f4*r4)/r5 gg = g*g; gg1= g*g1; gg2= g*g2; g1g1= g1*g1 ! (rr,zz)-definitions rr = Sqrt(wv1)/g; rhoi = bri/rr; zz = u/g rr2 = rr*rr; rr4= rr2*rr2 ;zz2= zz*zz ! (r,z)-derivatives drr1 = bri*rr/r; drz1 = bzi*zz/r drr2 = (bri2 - drr1**2)/r; drz2 = (bzi2 - drz1**2)/r drr12 = drr1**2; drz12 = drz1**2 ! (u,v)-derivatives uz1 = bzi*(g+g1*zz2/r); ur1 = bri*g1*rr*zz/r vz1 = bzi*two*gg1*rr2*zz/r vr1 = bri*two*rr*(gg+gg1*rr2/r) uz2 = bzi2*zz*(three*g1*r2-g1*zz2+g2*r*zz2)/r3 ur2 = bri2*(g1*r2-g1*rr2+g2*r*rr2)*zz/r3 vz2 = bzi2*two*rr2*(gg1*r2-gg1*zz2+g1g1*r*zz2+gg2*r*zz2)/r3 vr2 = gg*r3+five*gg1*r2*rr2-gg1*rr4+g1g1*r*rr4+gg2*r*rr4 vr2 = vr2*bri2*two/r3; ur12=ur1**2; vr12=vr1**2; uz12=uz1**2 vz12 = vz1**2 ! storage fh(ihli)= zz*bz; fl(ihli)= rr*bp; fli(ihli)=one/fl(ihli); fd(ihli)= fdd*fdd ! for first derivatives fp1(ihli)= fd1*drz1; fp2(ihli)= uz1; fp3(ihli)= vz1 fp4(ihli)= fd1*drr1; fp5(ihli)= ur1; fp6(ihli)= vr1 ! for the Laplacian fs1(ihli) = two*(ur12 + uz12); fs2(ihli) = two*(vr12 + vz12) fs3(ihli) = two*(fd1*(drr1*rhoi+drr2+drz2)+ & (fd12+fd2)*(drr12+drz12)) fs4(ihli) = two*(ur1*vr1 + uz1*vz1) fs5(ihli) = four*fd1*(drr1*ur1 + drz1*uz1) + & ur1*rhoi + ur2 + uz2 fs6(ihli) = four*fd1*(drr1*vr1 + drz1*vz1) + & vr1*rhoi + vr2 + vz2 - (vr12 +vz12)/wv1 End Do !ihs End Do !il ! ! Associated (z,r)-weights Do il = 1,ngl Do ih = 1,ngh i = ih + (il-1)*ngh wdcor(i) = pi*wh(ih)*wl(il)*bz*bp*bp/fd(i) wdcori(i)=one/wdcor(i) End Do End Do ! If(lpr) Then Do iw=lout,lfile Write(iw,*) If(ilst1.Eq.0) Then Write(iw,*) ' ### HO case: wdcor charged' Else Write(iw,*) ' ### THO case: wdcor charged' End If Write(iw,*) End Do End If Return End Subroutine f01234 !======================================================================= ! !======================================================================= Subroutine thofun(key,r,f,f1,f2,f3,fj,lpr,units) !--------------------------------------------------------------------- ! Calculates LST-function 'f' its derivatives 'f1,f2,f3' ! at the point 'r' (all dimensionless). !--------------------------------------------------------------------- Use HFBTHO Implicit None Logical :: lpr,units Integer(ipr) :: key,msw Integer(ipr) :: it,iter,ir,iqq,irmax,irmsit,immho,imm1,& imm2,immm,immmax,imm3 Real(pr) :: r,f,f1,f2,f3,fj,toto Real(pr), Allocatable :: dsx(:),dsy(:),dsyT(:),dsyi(:),dsyii(:),dsy1(:), & dsy1i(:),spb0(:),spc0(:),spd0(:),spbi(:),spci(:),spdi(:) Real(pr) :: h,hhb,pihhb,c00,snorm,snorm1,assm,asm1,asm2,asm3, & rmsit,rmmho,z1,z10,aaa,bex,rend,fj1,fj2,fj3, & s,s1,sN,sP,sT,qq,qqup,qqdn,zqq,zqqi,df,zfj1,zfj1i,fjb,aa,bb,yyy,& sqsq,rmmm,rmmmb0,z1mmm,rmm1,rmm1b0,z1mm1,rmm2,rmm2b0,z1mm2, & rmmmax,z1mmmax,rmmmaxb0,rmmx,z1mmx,z1mmxx,alaex,aldsy1,decay2 Real(pr) :: denm1(2),denm2(2),rdenm(2) Real(pr) :: epsf=1.0d-14,epsdsy=1.0d-16,epsnorm Complex(pr) :: yyy1,bbb1,aac !for the e3rd order equation ! ! Adjustable parameters ! Rend=40.0_pr epsnorm=0.01_pr ! =========================== ! KEY=0 INITIAL CALCULATIONS ! =========================== qq = r If(key.Eq.0.And.ilst.Le.0) Then write(*,*) write(*,*) ' LST transformation...' ! ! steps h = 0.01_pr; hhb = b0*h; If(units) hhb = h pihhb = 4.0_pr*pi*hhb ! ! correct density asymptotic ! !================================ ! Test neutron/proton asymptotic !================================ Do it=1,2 ! Neutron/proton density decay constant itass=it; decay=ass(itass); decay2=decay**2; rmsit=rms(itass)+one; irmsit=Int(rmsit/hhb) bb=Real((itass-1)*npr(2),Kind=pr)*Sqrt(1.440_pr)/hb0 ! correct density Rend Rend=40.0_pr; irmax=Int(Rend/hhb) ! Deallocate/Allocate if(Allocated(dsx)) Deallocate(dsx,dsy,dsyT,dsyi,dsyii,dsy1,dsy1i,& spb0,spc0,spd0,spbi,spci,spdi) Allocate(dsx(irmax),dsy(irmax),dsyT(irmax),dsyi(irmax),dsyii(irmax), & dsy1(irmax),dsy1i(irmax),spb0(irmax),spc0(irmax),spd0(irmax),& spbi(irmax),spci(irmax),spdi(irmax)) ! HFB+HO_{L=0} density 'dsy' and its normalization ! integral 'dsyi' at points 'dsx' with step 'hhb=h*b0' ! up to the point where 'dsy*dsx*dsx < epsdsy' msw=0; snorm=zero Do While(Abs(snorm-Real(npr(itass),Kind=pr)).Gt.epsnorm.And.msw.Lt.25) msw=msw+6 ! increase for good norm of HFB+HO_{L=0} itass = - itass; s1 = zero Do ir=1,irmax rmmho=hhb*Real(ir,Kind=pr); immho=ir ! L=0 component of density for isospin it (s) and isospin 1-it (sT) Call densitr(itass,rmmho,sN,sP,msw) if(itass.eq.1) then s=sN; sT=sP else s=sP; sT=sN End If s=s*Dnfactor(itass) z1=s*rmmho**2; s1=s1+z1 ! density dsy(ir) at point ir and its integral over r dsyi(ir) ! up to that point dsyT(ir)=sT; dsy(ir)=s; dsyi(ir)=hhb*s1 immho=ir !up to the point immho If(z1.Lt.epsdsy) Exit End Do snorm=pihhb*s1 ! HFB+HO_{L=0} norm End Do ! dsy: density, spb0: first derivative with respect to r Call deri(hhb,immho,dsy,spb0) ! MIN: Find 'rmm1', the first minimum of Ln(HFB+HO_{L=0})' z10 = 1.0d10 Do ir=irmsit,immho-5 denm1(it)=dsy(ir); denm2(it)=dsyT(ir) z1 = spb0(ir)/dsy(ir) If(z1.Le.z10) Then imm1 = ir; rmm1 = hhb*Real(ir,Kind=pr); z1mm1= z1; Else; Exit End If z10 = z1 End Do rdenm(itass) = rmm1/b0 If(units) rdenm(itass) = rmm1 ! no minimum of Ln(HFB+HO_{L=0})' If(rmm1.Ge.hhb*Real(immho-5,Kind=pr)) Then Write(*,*) Write(*,*) '#####################################' Write(*,*) 'Please increase Nsh NB!!!(NO THO RUN)' Write(*,*) '#####################################' Write(*,*) iasswrong(itass)=-1 Stop !If(lpr) Then ! Open(1110,file='dat0.dat') ! Write(1110,*) ' r rhoh Log(rhoh)' ! Do ir=5,immho-5 ! Write(1110,'(14(4x,e13.6))') hhb*Real(ir),dsy(ir),spb0(ir)/dsy(ir) ! End Do ! Close(1110) !End If !Return End If End do ! Asymptotics - denm1: density for isospin it, denm2: density for isospin 1-it If((denm1(1)-denm2(1))*(denm2(2)-denm1(2)).Le.zero) Then itass=1; if(ass(1).gt.ass(2)) itass=2 ! mismatch: use old asymptotic (lower decay) Else itass=2; If(denm1(1).gt.denm2(1)) itass=1 ! use new asymptotic (higher density) End If ! iasswrong(3)=0 If(iasswrong(itass).ne.0) iasswrong(3)=iasswrong(itass) ! wrong assymptotic => reinforce HO results ! Write(*,*) ' min.point neutron density proton density' Write(*,*) ' 1. Neutron min.point ',rdenm(1),denm1(1),denm2(1) Write(*,*) ' 2. Protons min.point ',rdenm(2),denm2(2),denm1(2) Write(*,*) ' Neutron/Proton decay',ass(1),'/',ass(2) Write(*,*) ' Chosen Case=',itass ! !=================== ! Actual asymptotic !=================== ! neutron/proton density decay constant decay = ass(itass); decay2=decay**2; rmsit= rms(itass)+one;irmsit=Int(rmsit/hhb) bb = Real((itass-1)*npr(2),Kind=pr)*Sqrt(1.440_pr)/hb0 ! correct density Rend Rend = 40.0_pr; irmax = Int(Rend/hhb) ! Deallocate/Allocate If(Allocated(dsx)) Deallocate(dsx,dsy,dsyT,dsyi,dsyii,dsy1,dsy1i,& spb0,spc0,spd0,spbi,spci,spdi) Allocate(dsx(irmax),dsy(irmax),dsyi(irmax),dsyii(irmax), & dsy1(irmax),dsy1i(irmax),spb0(irmax),spc0(irmax), & spd0(irmax),spbi(irmax),spci(irmax),spdi(irmax)) ! HFB+HO_{L=0} density 'dsy' and its normalization ! integral 'dsyi' at points 'dsx' with step 'hhb=h*b0' ! up to the point where 'dsy*dsx*dsx < epsdsy' msw = 0; snorm=zero Do While(Abs(snorm-Real(npr(itass),Kind=pr)).Gt.0.01.And.msw.Lt.25) msw = msw + 6 ! increase for good norm of HFB+HO_{L=0} itass = - itass; s1 = zero Do ir=1,irmax rmmho = hhb*Real(ir,Kind=pr); immho = ir Call densitr(itass,rmmho,sN,sP,msw) if(itass.eq.1) then s=sN; sT=sP else s=sP; sT=sN End If s=s*Dnfactor(itass) z1 = s*rmmho**2; s1 = s1 + z1 dsy(ir)= s; dsyi(ir)= hhb*s1 !p-ho density and its integral immho = ir !up to the point immho If(z1.Lt.epsdsy) Exit End Do snorm = pihhb*s1 ! HFB+HO_{L=0} norm End Do Call deri(hhb,immho,dsy,spb0) ! MIN: Find 'rmm1', the first minimun of Ln(HFB+HO_{L=0})' z10 = 1.0d10 Do ir=irmsit,immho-5 z1 = spb0(ir)/dsy(ir) If(z1.Le.z10) Then imm1 = ir; rmm1 = hhb*Real(ir,Kind=pr); z1mm1= z1; Else; Exit End If z10 = z1 End Do rmm1b0 = rmm1/b0 If(units) rmm1b0 = rmm1 ! MAX: Find 'rmmmax', the first maximum of ln(HFB+HO_{L=0})' z10 = z1mm1 Do ir=imm1,immho-5 z1 = spb0(ir)/dsy(ir) If(z1.Ge.z10) Then immmax = ir; rmmmax = hhb*Real(ir,Kind=pr); z1mmmax= z1; Else; Exit End If z10 = z1 End Do rmmmaxb0 = rmmmax/b0 If(units) rmmmaxb0 = rmmmax ! ! END: Find 'rmm2', the last point of ln(HFB+HO_{L=0}) at the level of the first minimum z10 = z1mm1 Do ir=immmax,immho-5 z1 = spb0(ir)/dsy(ir) If(z1.Ge.z10) Then imm2 = ir; rmm2 = hhb*Real(ir,Kind=pr); z1mm2= z1 End If End Do rmm2b0 = rmm2/b0 If(units) rmm2b0 = rmm2 ! ! MID: Find 'rmmm', the MinMaX mid point z10 = half*(z1mmmax+z1mm1) Do ir=imm1,immho z1 = spb0(ir)/dsy(ir) If(z1.Ge.z10) Exit immm = ir; rmmm = hhb*Real(ir,Kind=pr); z1mmm= z1 End Do rmmmb0 = rmmm/b0 If(units) rmmmb0 = rmmm ! ------------------------------------------------------------- ! Important points required: ! Minimum point 'rmm1' and its log.density 'z1mm1' ! First maximum 'rmmmax' and its log.density 'z1mmmax' ! Last acceptable point 'rmm2' and its log.density 'z1mm2' ! Mid point 'rmmm' and its log.density 'z1mmm' ! ------------------------------------------------------------- ! fit 'aa' from the mid match point 'rmmm','z1mmm' If(z1mmm.Ge.-decay) z1mmm= (-decay+z1mm1)/two !just in case ! the 3rd order equation sqsq = rmmm*(two*bb+decay2*rmmm) bbb1 = one + rmmm*z1mmm yyy1 =(2.0_pr*bbb1**6 + 18.0_pr*bbb1**3*sqsq + 27.0_pr*sqsq**2 + & 3.0_pr*Sqrt(3.0_pr)*sqsq**1.5_pr*Sqrt(4.0_pr*bbb1**3 + & 27.0_pr*sqsq))**(1.0_pr/3.0_pr) aa = Real((2.*bbb1**2*yyy1 + 2.**(2.0_pr/3.0_pr)*yyy1**2 - & 2.*2.**(1.0_pr/3.0_pr)*(-bbb1**4 - & 6.0_pr*bbb1*sqsq))/(6.*yyy1),Kind=pr) aa = (-4.0_pr*bb*rmmm - decay2*rmmm**2 + aa)*0.250_pr !write(*,*) ' aa= ',aa !If(aa.Le.zero) aa = zero ! in this case take l=0 ! ! matching logder at Rmin='rmm1' and 'rmmx' ! log density for rmm1 rmmx) dsy1(ir) = Exp(bex + yyy) End If End If End Do ! correct density norm snorm1 = pihhb*Sum(dsy1*dsx*dsx) ! normalized correct density 'dsy1' dsy1 = snorm*dsy1/snorm1 ! zero constant c00 = (dsy1(1)/dsy(1))**(1.0_pr/3.0_pr) ! splining correct density and its integral s1 = zero Do ir=1,irmax s1 = s1 + dsy1(ir)*dsx(ir)**2 dsy1i(ir) = hhb*s1 End Do ! ! correct density dsy1 and its integral dsy1i known up to irmax Call csplin(irmax,dsx,dsy1 ,spb0,spc0,spd0) Call csplin(irmax,dsx,dsy1i,spbi,spci,spdi) ! ! print 'dat1.dat' with HFB+HO and 'correct' densities ! and their Log derivatives at lpr=.true. If(lpr) Then Open(1110,file='density.dat') !Write(1110,*) ' r rhoh rhoc Log(rhoh)'' Log(rhoc)'' ' !Do ir=5,immho-5 Do ir=5,irmax-5 ! ho density derivative s =(45.0_pr*( dsy(ir+1)-dsy(ir-1))-9.0_pr*& (dsy(ir+2)-dsy(ir-2))+dsy(ir+3)-dsy(ir-3))/(60.0_pr*hhb)/dsy(ir) !correct density derivative s1=(45.0_pr*(dsy1(ir+1)-dsy1(ir-1))-9.0_pr*(dsy1(ir+2)-& dsy1(ir-2))+dsy1(ir+3)-dsy1(ir-3))/(60.0_pr*hhb)/dsy1(ir) Write(1110,'(2(1x,e13.6))') dsx(ir),dsy1(ir) End Do Close(1110) !Open(1111,file='dat1.dat') !Write(1111,*) ' Dimensionless_qq Invers_f Invers_f1 Invers_f2 Invers_f3 ' End If ! ! ======================================= ! Calculations at given dimensionless 'qq' ! ======================================= ! f(R->0) = c00*R, therefore Invers_f(R)=R/c00 fj = h/c00 bmm3= zero; z1 = zero; ir=0 Do iqq=1,immho qq = Real(iqq,Kind=pr)*h ! HFB+HO density and integral at 'b0*qq' or 'qq' zqq = dsy(iqq); zqqi = dsyi(iqq) ! Iterations to find 'fj = Invers_f(qq)' ! NB! f[Invers_f(qq)]=qq iter= 0; df= 0.00010_pr Do While(Abs(df).Ge.epsf.And.iter.Le.500) iter = iter + 1 fjb = fj*b0; If(units) fjb=fj Call cseval(irmax,fjb,dsx,dsy1 ,spb0,spc0,spd0,zfj1 ) Call cseval(irmax,fjb,dsx,dsy1i,spbi,spci,spdi,zfj1i) qqup = (Log(zfj1i/zqqi))*zfj1i; qqdn = zfj1*b0*fjb**2; If(units) qqdn=zfj1*fjb**2 ! Secant & Newton If(zfj1i.Le.zqqi.And.df.Le.0.0_pr) df=-half*df If(zfj1i.Gt.zqqi.And.df.Gt.0.0_pr) df=-half*df If(Abs(qqdn).Gt.Abs(qqup).And.iter.Le.20) df= - qqup/qqdn fj = fj + df End Do fj1 = (zqq*qq*qq)/(zfj1*fj*fj) fj2 = (fj1 - z1)/h; z1 =fj1 If(qq.Gt.rmm2b0) Then If(fj1.Ge.bmm3) Then bmm3 = fj1; Else; Exit End If End If dsy(iqq) = fj dsyi(iqq) = fj1 dsyii(iqq) = fj2 iqqmax = iqq End Do imm3 = iqqmax-50 rmm3 = Real(imm3,Kind=pr)*h amm3 = dsy(imm3) bmm3 = dsyi(imm3) cmm3 = dsyii(imm3) ! second and third derivatives up to 'iqqmax'' Call deri(h,iqqmax,dsyi,spb0) Call deri(h,iqqmax,spb0,spc0) ! If(Allocated(fdsx)) Deallocate(fdsx,fdsy,fdsy1,fdsy2,fdsy3,fspb0,fspc0, & fspd0,fspb1,fspc1,fspd1,fspb2,fspc2,fspd2,& fspb3,fspc3,fspd3) Allocate(fdsx(iqqmax),fdsy(iqqmax),fdsy1(iqqmax),fdsy2(iqqmax), & fdsy3(iqqmax),fspb0(iqqmax),fspc0(iqqmax),fspd0(iqqmax),& fspb1(iqqmax),fspc1(iqqmax),fspd1(iqqmax),fspb2(iqqmax),& fspc2(iqqmax),fspd2(iqqmax),fspb3(iqqmax),fspc3(iqqmax),& fspd3(iqqmax)) Do iqq=1,iqqmax fdsx(iqq) = Real(iqq,Kind=pr)*h fdsy(iqq) = dsy(iqq) fdsy1(iqq) = dsyi(iqq) fdsy2(iqq) = spb0(iqq) fdsy3(iqq) = spc0(iqq) ! ! print 'dat1.dat' with fj=Inverse_f(qq) and its derivatives ! fj1..3 at no smoothing when lpr=.true. !If(lpr) Then ! Write(1111,'(14(4x,e13.6))') fdsx(iqq)*b0,fdsy(iqq),& ! fdsy1(iqq),fdsy2(iqq),fdsy3(iqq) !End If End Do ! If(Allocated(dsx)) Deallocate(dsx,dsy,dsyi,dsyii,dsy1,dsy1i,& spb0,spc0,spd0,spbi,spci,spdi) ! Call csplin(iqqmax,fdsx,fdsy ,fspb0,fspc0,fspd0) Call csplin(iqqmax,fdsx,fdsy1,fspb1,fspc1,fspd1) Call csplin(iqqmax,fdsx,fdsy2,fspb2,fspc2,fspd2) Call csplin(iqqmax,fdsx,fdsy3,fspb3,fspc3,fspd3) ! Do ir=lout,lfile Write(ir,*) Write(ir,*) ' Legendre points = ',msw Write(ir,*) ' b0, decay= ',b0,decay Write(ir,*) ' h, hhb= ',h,hhb Write(ir,*) ' rms, rmsit= ',rms(itass),rmsit Write(ir,*) ' Rend, irmax= ',Rend,irmax Write(ir,*) ' HORend, immho= ',rmmho,immho Write(ir,*) ' snorm,snorm1= ',snorm,snorm1 Write(ir,*) ' snorm/snorm1= ',snorm/snorm1 Write(ir,*) ' min:rmm1,/b0= ',rmm1,rmm1b0 Write(ir,*) ' max:rmmmax,/b0= ',rmmmax,rmmmaxb0 Write(ir,*) ' last:rmm2,/b0= ',rmm2,rmm2b0 Write(ir,*) ' num:rmm3*b0,rmm3= ',rmm3*b0,rmm3 Write(ir,*) ' rmmho, rmmho/b0= ',rmmho,rmmho/b0 Write(ir,*) ' alaex,bex= ',alaex,bex Write(ir,*) ' aa,bb= ',aa,bb Write(ir,*) ' L_eff= ',(Sqrt(one + 4.0_pr*aac)-one)/two Write(ir,*) ' amm3, bmm3= ',amm3,bmm3 Write(ir,*) ' cmm3, one/c00= ',cmm3,one/c00 Write(ir,*) ' z1mm1,z1mmm= ',z1mm1,z1mmm Write(ir,*) End Do !! print 'dat2..4.dat' after when lpr=.true. !! dat2.dat: 'r=b0*qq',correct density !! dat3.dat qq, Invers_f,Invers_f1...3 !! dat4.dat qq, f,f1,f2,f3; 'qq' are the Gauss points !If(lpr) Then ! Close(1111) ! Open(1112,file='dat2.dat') ! Open(1113,file='dat3.dat') ! Open(1114,file='dat4.dat') ! Write(1112,*) ' r den_correct' ! Write(1113,*) ' qq Invers_f Invers_f1 Invers_f2 Invers_f3' ! Write(1114,*) ' qq f f1 f2 f3' ! Do iqq=1,ngh ! Do ir=1,ngl ! qq = Sqrt(xh(iqq)**2+xl(ir)) ! Call densitr(itass,b0*qq,sN,sP,msw) ! if(itass.eq.1) then ! s=sN; sT=sP ! else ! s=sP; sT=sN ! End If ! s=s*Dnfactor(itass) ! If(qq.Le.rmm3) Then ! Call cseval(iqqmax,qq,fdsx,fdsy ,fspb0,fspc0,fspd0,fj) ! Call cseval(iqqmax,qq,fdsx,fdsy1,fspb1,fspc1,fspd1,fj1) ! Call cseval(iqqmax,qq,fdsx,fdsy2,fspb2,fspc2,fspd2,fj2) ! Call cseval(iqqmax,qq,fdsx,fdsy3,fspb3,fspc3,fspd3,fj3) ! Else ! fj = amm3+bmm3*(qq-rmm3)+cmm3*(qq-rmm3)**2/two ! fj1 = bmm3+cmm3*(qq-rmm3) ! fj2 = cmm3; fj3 = zero ! End If ! f = qq; f1 = one/fj1; f2 =-fj2*f1**3 ! f3 = three*fj2**2*f1**5-fj3*f1**4 ! s = s*qq*qq/(fj*fj*fj1) ! Write(1112,'(14(4x,e13.6))') b0*fj,s ! Write(1113,'(14(4x,e13.6))') qq,fj,fj1,fj2,fj3 ! Write(1114,'(14(4x,e13.6))') qq,f,f1,f2,f3 ! End Do ! End Do ! Close(1112); Close(1113); ! Close(1114) !End If ! ========================= Else !KEY=1 CALCULATIONS ! ========================= ! ! Calculations of Invers_f(qq),_f'(qq),_f''(qq),_f'''(qq) If(qq.Le.rmm3) Then Call cseval(iqqmax,qq,fdsx,fdsy ,fspb0,fspc0,fspd0,fj) Call cseval(iqqmax,qq,fdsx,fdsy1,fspb1,fspc1,fspd1,fj1) Call cseval(iqqmax,qq,fdsx,fdsy2,fspb2,fspc2,fspd2,fj2) Call cseval(iqqmax,qq,fdsx,fdsy3,fspb3,fspc3,fspd3,fj3) Else fj = amm3+bmm3*(qq-rmm3)+cmm3*(qq-rmm3)**2/two fj1 = bmm3+cmm3*(qq-rmm3); fj2 = cmm3; fj3 = zero End If ! Calculations of f(fj),f'(fj),f''(fj),f'''(fj) f = qq; f1 = one/fj1; f2 =-fj2*f1**3 f3 = three*fj2**2*f1**5-fj3*f1**4 End If Return End Subroutine thofun !======================================================================= ! !======================================================================= Subroutine densitr(it,xr,yr,yrP,msw) !--------------------------------------------------------------------- ! Calculates Legendre decomposition of neutron(proton) 'it=1(2)' ! HFB+HO_{L=0}(r) density 'yr' at point 'xr' (in fm) !--------------------------------------------------------------------- Use HFBTHO Implicit None Integer(ipr) :: it,msw Integer(ipr), Save :: iw,ik,il,i0,i02,jk,nsa,nsb,nrb,ny,nyy,ib,nd,& n1,n2,n1n2nd,ibit,ibitnb,nzb,mlb,ngh1,ngl1 ! msw=20 test for protons at the crazy case of U 212 120 92 ! msw=3 s,a1= 107.665062 80.82396 s/s1= 1.33209 ! msw=6 s,s1= 88.973061 80.99903 s/s1= 1.09844 ! msw=12 s,s1= 92.025592 80.99595 s/s1= 1.13617 ! msw=18 s,s1= 92.000017 80.99595 s/s1= 1.13585 ! msw=24 s,s1= 92.000010 80.99595 s/s1= 1.13585 ! Taken up to msw=24 Real(pr), Allocatable, Save :: xmw(:),yi(:,:) Real(pr) :: phy(msw,nzrlx),anl(msw,msw),yl(msw,msw) Real(pr), Save :: sl,w,hw,ct2,s,frit,fritP,wdcorin,bzi,bri,ct,st,z,t Real(pr) :: xr,yr,yrp ! ngh1=ngh+1; ngl1=ngl+1 If(it.Lt.0) Then it = -it If(Allocated(xmw)) Deallocate(xmw,yi) Allocate(xmw(msw),yi(msw,msw)) wdcorin=one/Sqrt(pi*bz*bpp); bzi=one/bz; bri=one/bp ! 'msw' mesh-points in 'angle' space xmw(1)=zero; hw=half*pi/Real(msw-1,Kind=pr) Do il=2,msw xmw(il)=hw*Real(il-1,Kind=pr) End Do ! coefficients for the L-decomposition sl=4.0_pr Do il=1,msw sl=0.250_pr*sl Do ny=1,il anl(ny,il) = iv(il-ny)*fak(2*(il+ny-2))*& fi(il-ny)*fi(il+ny-2)*fi(2*ny-2)*sl End Do End Do Do iw=1,msw w = xmw(iw); ct2 = Cos(w)**2 Do il=1,msw yi(iw,il) = zero; s = zero Do nyy=1,il ny = il + 1 - nyy; s = s*ct2 + anl(ny,il) End Do yl(iw,il) = s*sq(4*il-3) End Do yi(iw,iw) = one End Do Call lingd(msw,msw,msw,msw,yl,yi,s,il) End If ! 'xr/yr' calculations Do iw=1,msw w = xmw(iw); ct = Cos(w); st = Sin(w) z = ct*xr*bzi; t = (st*xr*bri)**2 Call gaupolr(z,t) ik = 0 Do ib = 1,nb nd= id(ib); i0= ia(ib) Do n2 = 1,nd ik = ik + 1; i02= i0 + n2 nzb= nz(i02); nrb= nr(i02); mlb = nl(i02) phy(iw,ik) = qh(nzb,ngh1)*ql(nrb,mlb,ngl1)*wdcorin End Do End Do End Do ! 'yr' over the blocks yr=zero; yrP=zero; ik = 0 Do ib = 1,nb nd= id(ib); i0= ia(ib) Do n2 = 1,nd jk= ik; ik= ik + 1; i02=i0 + n2; nsb= ns(i02) Do n1 = n2,nd jk= jk + 1; i02=i0 + n1; nsa= ns(i02) If(nsa.Eq.nsb) Then ibit=ib; ibitnb= ib+nbx; n1n2nd= n1+(n2-1)*nd frit = rk(n1n2nd,ibit); fritP = rk(n1n2nd,ibitnb) If(n1.Ne.n2) then frit = two*frit; fritP = two*fritP End If s = zero Do iw=1,msw s = s + yi(1,iw)*phy(iw,ik)*phy(iw,jk) End Do yr=yr+frit*s; yrP=yrP+fritP*s End If End Do !n2 End Do !n1 End Do !ib ! Return End Subroutine densitr !======================================================================= ! !======================================================================= Subroutine gaupolr(z,x) !--------------------------------------------------------------------- ! see 'gaupol' !--------------------------------------------------------------------- Use HFBTHO Implicit None Real(pr) :: z,x Real(pr) :: w0,w00,w4pii,dsq,d1,d2 Integer(ipr) :: N,L,NGH1,NGL1 ! NGH1=NGH+1; NGL1=NGL+1 W4PII = PI**(-0.250_pr); W0 = W4PII*Exp(-HALF*Z*Z) ! W0 = W0*SQRT(Z) NOT MULTIPLIED BY WDCOR QH(0,NGH1) = W0; QH(1,NGH1)= SQ(2)*W0*Z Do N = 2,NZM QH(N,NGH1) = SQI(N)*(SQ(2)*Z*QH(N-1,NGH1)-SQ(N-1)*QH(N-2,NGH1)) End Do W00 = SQ(2)*Exp(-HALF*X) Do L = 0,NLM If(L.Eq.0) Then W0 = W00*Sqrt(HALF) Else W0 = W00*Sqrt(HALF*X**L) End If QL(0,L,NGL1) = WFI(L)*W0; QL(1,L,NGL1) = (Real(L+1,Kind=pr)-X)*WFI(L+1)*W0 Do N = 2,NRM DSQ = SQ(N)*SQ(N+L); D1= Real(2*N + L - 1,Kind=pr) - X D2 = SQ(N-1)*SQ(N-1+L) QL(N,L,NGL1) = (D1*QL(N-1,L,NGL1)-D2*QL(N-2,L,NGL1))/DSQ End Do End Do Return End Subroutine gaupolr End Module HFBTHO_THO !================================================================================================================================== !#END THO MODULE !================================================================================================================================== !#START EllipticIntegral MODULE !================================================================================================================================== Module EllipticIntegral !-------------------------------------------------------------------------------------- ! This module provides a routine to compute the complete elliptic integral of ! the second kind. ! ! Reference: ! Fukushima, T., ! Fast Computation of Complete Elliptic Integrals and Jacobian Elliptic Functions, ! Celest. Mech. Dyn. Astron., 105, 305-328 (2009b) !-------------------------------------------------------------------------------------- Use HFBTHO_utilities Implicit None Contains Real(pr) Function CompleteEllipticFunction_2nd(x) Use HFBTHO_utilities Implicit None Real(pr), INTENT(IN) :: x Real(pr) :: Emp,Kmp,Em,Km,qp,pi,x_eff pi = four*Atan(one) If(x.Lt.zero.Or.x.Gt.one) Stop 'Error in CompleteEllipticFunction_2nd' If(x.Lt.0.9_pr) Then Em = elliptic_small_m(x) Else Call auxiliary(x,Emp,Kmp) x_eff = one-x; qp = nome(x_eff) Km = -Log(qp)*Kmp/pi Em = Km + (half*pi - Emp*Km)/Kmp End If CompleteEllipticFunction_2nd = Em End Function CompleteEllipticFunction_2nd !======================================================================= ! !======================================================================= Subroutine auxiliary(x,Emp,Kmp) Use HFBTHO_utilities Implicit None Real(pr), INTENT(IN) :: x Real(pr), INTENT(INOUT) :: Emp,Kmp Integer(ipr) :: JE, JK Parameter (JE=16, JK=16) Integer(ipr) :: i Real(pr) :: x0, x_eff Real(pr), Dimension(0:JE) :: Coeff_E Real(pr), Dimension(0:JK) :: Coeff_K x0 = 0.05_pr; x_eff = one - x Coeff_E(0) = +1.550973351780472328_pr Coeff_E(1) = -0.400301020103198524_pr Coeff_E(2) = -0.078498619442941939_pr Coeff_E(3) = -0.034318853117591992_pr Coeff_E(4) = -0.019718043317365499_pr Coeff_E(5) = -0.013059507731993309_pr Coeff_E(6) = -0.009442372874146547_pr Coeff_E(7) = -0.007246728512402157_pr Coeff_E(8) = -0.005807424012956090_pr Coeff_E(9) = -0.004809187786009338_pr Coeff_E(10)= 0.000000000000000000_pr Coeff_E(11)= 0.000000000000000000_pr Coeff_E(12)= 0.000000000000000000_pr Coeff_E(13)= 0.000000000000000000_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr Emp = 0.0_pr Do i=0,JE Emp = Emp + Coeff_E(i)*(x_eff - x0)**i End Do Coeff_K(0) = 1.591003453790792180_pr Coeff_K(1) = 0.416000743991786912_pr Coeff_K(2) = 0.245791514264103415_pr Coeff_K(3) = 0.179481482914906162_pr Coeff_K(4) = 0.144556057087555150_pr Coeff_K(5) = 0.123200993312427711_pr Coeff_K(6) = 0.108938811574293531_pr Coeff_K(7) = 0.098853409871592910_pr Coeff_K(8) = 0.091439629201749751_pr Coeff_K(9) = 0.085842591595413900_pr Coeff_K(10)= 0.081541118718303215_pr Coeff_K(11)= 0.000000000000000000_pr Coeff_K(12)= 0.000000000000000000_pr Coeff_K(13)= 0.000000000000000000_pr Coeff_K(14)= 0.000000000000000000_pr Coeff_K(15)= 0.000000000000000000_pr Coeff_K(16)= 0.000000000000000000_pr Kmp = 0.0_pr Do i=0,JK Kmp = Kmp + Coeff_K(i)*(x_eff - x0)**i End Do End Subroutine auxiliary !======================================================================= ! !======================================================================= Real(pr) Function elliptic_small_m(x) Use HFBTHO_utilities Implicit None Real(pr), INTENT(IN) :: x Integer(ipr) :: JE Parameter (JE=16) Integer(ipr) :: i Real(pr) :: x0, Em Real(pr), Dimension(0:JE) :: Coeff_E If(x.Lt.0.1_pr) Then x0 = 0.05_pr Coeff_E(0) = +1.550973351780472328_pr Coeff_E(1) = -0.400301020103198524_pr Coeff_E(2) = -0.078498619442941939_pr Coeff_E(3) = -0.034318853117591992_pr Coeff_E(4) = -0.019718043317365499_pr Coeff_E(5) = -0.013059507731993309_pr Coeff_E(6) = -0.009442372874146547_pr Coeff_E(7) = -0.007246728512402157_pr Coeff_E(8) = -0.005807424012956090_pr Coeff_E(9) = -0.004809187786009338_pr Coeff_E(10)= 0.000000000000000000_pr Coeff_E(11)= 0.000000000000000000_pr Coeff_E(12)= 0.000000000000000000_pr Coeff_E(13)= 0.000000000000000000_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.1_pr.And.x.Lt.0.2_pr) Then x0 = 0.15_pr Coeff_E(0) = +1.510121832092819728_pr Coeff_E(1) = -0.417116333905867549_pr Coeff_E(2) = -0.090123820404774569_pr Coeff_E(3) = -0.043729944019084312_pr Coeff_E(4) = -0.027965493064761785_pr Coeff_E(5) = -0.020644781177568105_pr Coeff_E(6) = -0.016650786739707238_pr Coeff_E(7) = -0.014261960828842520_pr Coeff_E(8) = -0.012759847429264803_pr Coeff_E(9) = -0.011799303775587354_pr Coeff_E(10)= -0.011197445703074968_pr Coeff_E(11)= 0.000000000000000000_pr Coeff_E(12)= 0.000000000000000000_pr Coeff_E(13)= 0.000000000000000000_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.2_pr.And.x.Lt.0.3_pr) Then x0 = 0.25_pr Coeff_E(0) = +1.467462209339427155_pr Coeff_E(1) = -0.436576290946337775_pr Coeff_E(2) = -0.105155557666942554_pr Coeff_E(3) = -0.057371843593241730_pr Coeff_E(4) = -0.041391627727340220_pr Coeff_E(5) = -0.034527728505280841_pr Coeff_E(6) = -0.031495443512532783_pr Coeff_E(7) = -0.030527000890325277_pr Coeff_E(8) = -0.030916984019238900_pr Coeff_E(9) = -0.032371395314758122_pr Coeff_E(10)= -0.034789960386404158_pr Coeff_E(11)= 0.000000000000000000_pr Coeff_E(12)= 0.000000000000000000_pr Coeff_E(13)= 0.000000000000000000_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.3_pr.And.x.Lt.0.4_pr) Then x0 = 0.35_pr Coeff_E(0) = +1.422691133490879171_pr Coeff_E(1) = -0.459513519621048674_pr Coeff_E(2) = -0.125250539822061878_pr Coeff_E(3) = -0.078138545094409477_pr Coeff_E(4) = -0.064714278472050002_pr Coeff_E(5) = -0.062084339131730311_pr Coeff_E(6) = -0.065197032815572477_pr Coeff_E(7) = -0.072793895362578779_pr Coeff_E(8) = -0.084959075171781003_pr Coeff_E(9) = -0.102539850131045997_pr Coeff_E(10)= -0.127053585157696036_pr Coeff_E(11)= -0.160791120691274606_pr Coeff_E(12)= 0.000000000000000000_pr Coeff_E(13)= 0.000000000000000000_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.4_pr.And.x.Lt.0.5_pr) Then x0 = 0.45_pr Coeff_E(0) = +1.375401971871116291_pr Coeff_E(1) = -0.487202183273184837_pr Coeff_E(2) = -0.153311701348540228_pr Coeff_E(3) = -0.111849444917027833_pr Coeff_E(4) = -0.108840952523135768_pr Coeff_E(5) = -0.122954223120269076_pr Coeff_E(6) = -0.152217163962035047_pr Coeff_E(7) = -0.200495323642697339_pr Coeff_E(8) = -0.276174333067751758_pr Coeff_E(9) = -0.393513114304375851_pr Coeff_E(10)= -0.575754406027879147_pr Coeff_E(11)= -0.860523235727239756_pr Coeff_E(12)= -1.308833205758540162_pr Coeff_E(13)= 0.000000000000000000_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.5_pr.And.x.Lt.0.6_pr) Then x0 = 0.55_pr Coeff_E(0) = +1.325024497958230082_pr Coeff_E(1) = -0.521727647557566767_pr Coeff_E(2) = -0.194906430482126213_pr Coeff_E(3) = -0.171623726822011264_pr Coeff_E(4) = -0.202754652926419141_pr Coeff_E(5) = -0.278798953118534762_pr Coeff_E(6) = -0.420698457281005762_pr Coeff_E(7) = -0.675948400853106021_pr Coeff_E(8) = -1.136343121839229244_pr Coeff_E(9) = -1.976721143954398261_pr Coeff_E(10)= -3.531696773095722506_pr Coeff_E(11)= -6.446753640156048150_pr Coeff_E(12)= -11.97703130208884026_pr Coeff_E(13)= 0.000000000000000000_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.6_pr.And.x.Lt.0.7_pr) Then x0 = 0.65_pr Coeff_E(0) = +1.270707479650149744_pr Coeff_E(1) = -0.566839168287866583_pr Coeff_E(2) = -0.262160793432492598_pr Coeff_E(3) = -0.292244173533077419_pr Coeff_E(4) = -0.440397840850423189_pr Coeff_E(5) = -0.774947641381397458_pr Coeff_E(6) = -1.498870837987561088_pr Coeff_E(7) = -3.089708310445186667_pr Coeff_E(8) = -6.667595903381001064_pr Coeff_E(9) = -14.89436036517319078_pr Coeff_E(10)= -34.18120574251449024_pr Coeff_E(11)= -80.15895841905397306_pr Coeff_E(12)= -191.3489480762984920_pr Coeff_E(13)= -463.5938853480342030_pr Coeff_E(14)= -1137.380822169360061_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.7_pr.And.x.Lt.0.8_pr) Then x0 = 0.75_pr Coeff_E(0) = +1.211056027568459525_pr Coeff_E(1) = -0.630306413287455807_pr Coeff_E(2) = -0.387166409520669145_pr Coeff_E(3) = -0.592278235311934603_pr Coeff_E(4) = -1.237555584513049844_pr Coeff_E(5) = -3.032056661745247199_pr Coeff_E(6) = -8.181688221573590762_pr Coeff_E(7) = -23.55507217389693250_pr Coeff_E(8) = -71.04099935893064956_pr Coeff_E(9) = -221.8796853192349888_pr Coeff_E(10)= -712.1364793277635425_pr Coeff_E(11)= -2336.125331440396407_pr Coeff_E(12)= -7801.945954775964673_pr Coeff_E(13)= -26448.19586059191933_pr Coeff_E(14)= -90799.48341621365251_pr Coeff_E(15)= -315126.0406449163424_pr Coeff_E(16)= -1104011.344311591159_pr End If If(x.Ge.0.8_pr.And.x.Lt.0.85_pr) Then x0 = 0.825_pr Coeff_E(0) = +1.161307152196282836_pr Coeff_E(1) = -0.701100284555289548_pr Coeff_E(2) = -0.580551474465437362_pr Coeff_E(3) = -1.243693061077786614_pr Coeff_E(4) = -3.679383613496634879_pr Coeff_E(5) = -12.81590924337895775_pr Coeff_E(6) = -49.25672530759985272_pr Coeff_E(7) = -202.1818735434090269_pr Coeff_E(8) = -869.8602699308701437_pr Coeff_E(9) = -3877.005847313289571_pr Coeff_E(10)= -17761.70710170939814_pr Coeff_E(11)= -83182.69029154232061_pr Coeff_E(12)= -396650.4505013548170_pr Coeff_E(13)= -1920033.413682634405_pr Coeff_E(14)= 0.000000000000000000_pr Coeff_E(15)= 0.000000000000000000_pr Coeff_E(16)= 0.000000000000000000_pr End If If(x.Ge.0.85_pr.And.x.Lt.0.9_pr) Then x0 = 0.875_pr Coeff_E(0) = +1.124617325119752213_pr Coeff_E(1) = -0.770845056360909542_pr Coeff_E(2) = -0.844794053644911362_pr Coeff_E(3) = -2.490097309450394453_pr Coeff_E(4) = -10.23971741154384360_pr Coeff_E(5) = -49.74900546551479866_pr Coeff_E(6) = -267.0986675195705196_pr Coeff_E(7) = -1532.665883825229947_pr Coeff_E(8) = -9222.313478526091951_pr Coeff_E(9) = -57502.51612140314030_pr Coeff_E(10)= -368596.1167416106063_pr Coeff_E(11)= -2415611.088701091428_pr Coeff_E(12)= -16120097.81581656797_pr Coeff_E(13)= -109209938.5203089915_pr Coeff_E(14)= -749380758.1942496220_pr Coeff_E(15)= -5198725846.725541393_pr Coeff_E(16)= -36409256888.12139973_pr End If Em = 0.0_pr Do i=0,JE Em = Em + Coeff_E(i)*(x - x0)**i End Do elliptic_small_m = Em End Function elliptic_small_m !======================================================================= ! !======================================================================= Real(pr) Function nome(x) Use HFBTHO_utilities Implicit None Real(pr), INTENT(IN) :: x Integer(ipr) :: Jq Parameter (Jq = 14) Integer(ipr) :: i Real(pr) :: qp,epsilon Real(pr), Dimension(1:Jq) :: Coeff_q epsilon = 1.D-14 Coeff_q(1) = 1.0_pr/16.0_pr Coeff_q(2) = 1.0_pr/32.0_pr Coeff_q(3) = 21.0_pr/1024.0_pr Coeff_q(4) = 31.0_pr/2048.0_pr Coeff_q(5) = 6257.0_pr/524288.0_pr Coeff_q(6) = 10293.0_pr/1048576.0_pr Coeff_q(7) = 279025.0_pr/33554432.0_pr Coeff_q(8) = 483127.0_pr/67108864.0_pr Coeff_q(9) = 435506703.0_pr/68719476736.0_pr Coeff_q(10) = 776957575.0_pr/137438953472.0_pr Coeff_q(11) = 22417045555.0_pr/4398046511104.0_pr Coeff_q(12) = 40784671953.0_pr/8796093022208.0_pr Coeff_q(13) = 9569130097211.0_pr/2251799813685248.0_pr Coeff_q(14) = 17652604545791.0_pr/4503599627370496.0_pr qp = 0.0_pr If(x.Gt.epsilon) Then Do i=1,Jq qp = qp + Coeff_q(i) * (x**i) End Do Else qp = epsilon End If nome = qp End Function nome End Module EllipticIntegral !================================================================================================================================== !#END EllipticIntegral !================================================================================================================================== !#START bessik !================================================================================================================================== Module bessik Use HFBTHO_utilities Implicit None Contains Function besei0(x) !--------------------------------------------------------------------- ! BESEI0 evaluates the exponentially scaled Bessel I0(X) function. ! ! Discussion: ! ! This routine computes approximate values for the modified Bessel ! function of the first kind of order zero multiplied by EXP(-ABS(X)). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 2007 ! ! Author: ! ! Original FORTRAN77 version by William Cody. ! FORTRAN90 version by John Burkardt. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) BESEI0, the value of the function. !--------------------------------------------------------------------- Implicit None Real(Kind=pr) :: besei0 Integer(Kind=ipr) :: jint Real(Kind=pr) :: result,x jint = 2 Call calci0(x,result,jint) besei0 = result Return End Function besei0 !======================================================================= ! !======================================================================= Function besei1(x) !--------------------------------------------------------------------- ! BESEI1 evaluates the exponentially scaled Bessel I1(X) function. ! ! Discussion: ! ! This routine computes approximate values for the ! modified Bessel function of the first kind of order one ! multiplied by EXP(-ABS(X)). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 2007 ! ! Author: ! ! Original FORTRAN77 version by William Cody. ! FORTRAN90 version by John Burkardt. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) BESEI1, the value of the function. !--------------------------------------------------------------------- Implicit none Real(Kind=pr) :: besei1 Integer(Kind=ipr) :: jint Real(Kind=pr) :: result,x jint = 2 Call calci1 ( x, result, jint ) besei1 = result Return End Function besei1 !======================================================================= ! !======================================================================= subroutine calci0 ( arg, result, jint ) !--------------------------------------------------------------------- ! !! CALCI0 computes various I0 Bessel functions. ! ! Discussion: ! ! This routine computes modified Bessel functions of the first kind ! and order zero, I0(X) and EXP(-ABS(X))*I0(X), for real ! arguments X. ! ! The main computation evaluates slightly modified forms of ! minimax approximations generated by Blair and Edwards, Chalk ! River (Atomic Energy of Canada Limited) Report AECL-4928, ! October, 1974. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 2007 ! ! Author: ! ! Original FORTRAN77 version by William Cody, Laura Stoltz. ! FORTRAN90 version by John Burkardt. ! ! Parameters: ! ! Input, real ( kind = 8 ) ARG, the argument. If JINT = 1, then ! the argument must be less than XMAX. ! ! Output, real ( kind = 8 ) RESULT, the value of the function, ! which depends on the input value of JINT: ! 1, RESULT = I0(x); ! 2, RESULT = exp(-x) * I0(x); ! ! Input, integer ( kind = 4 ) JINT, chooses the function to be computed. ! 1, I0(x); ! 2, exp(-x) * I0(x); !--------------------------------------------------------------------- Implicit None Real(Kind=pr) :: a,arg,b,exp40,forty Integer(Kind=ipr) :: i,jint Real(Kind=pr) :: one5,p(15),pp(8),q(5),qq(7),result,rec15 Real(Kind=pr) :: sump,sumq,two25,x,xinf,xmax,xsmall,xx ! Mathematical constants Data one5 /15.0_pr/ Data exp40 /2.353852668370199854d17/ Data forty /40.0_pr/ Data rec15 /6.6666666666666666666d-2/ Data two25 /225.0_pr/ ! Machine-dependent constants Data xsmall /5.55d-17/ !Data xinf /1.79d308/ Data xmax /713.986_pr/ ! Coefficients for XSMALL <= ABS(ARG) < 15.0 Data p/-5.2487866627945699800d-18,-1.5982226675653184646d-14, & -2.6843448573468483278d-11,-3.0517226450451067446d-08, & -2.5172644670688975051d-05,-1.5453977791786851041d-02, & -7.0935347449210549190d+00,-2.4125195876041896775d+03, & -5.9545626019847898221d+05,-1.0313066708737980747d+08, & -1.1912746104985237192d+10,-8.4925101247114157499d+11, & -3.2940087627407749166d+13,-5.5050369673018427753d+14, & -2.2335582639474375249d+15/ Data q/-3.7277560179962773046d+03, 6.5158506418655165707d+06, & -6.5626560740833869295d+09, 3.7604188704092954661d+12, & -9.7087946179594019126d+14/ ! Coefficients for 15.0 <= ABS(ARG) Data pp/-3.9843750000000000000d-01, 2.9205384596336793945d+00, & -2.4708469169133954315d+00, 4.7914889422856814203d-01, & -3.7384991926068969150d-03,-2.6801520353328635310d-03, & 9.9168777670983678974d-05,-2.1877128189032726730d-06/ Data qq/-3.1446690275135491500d+01, 8.5539563258012929600d+01, & -6.0228002066743340583d+01, 1.3982595353892851542d+01, & -1.1151759188741312645d+00, 3.2547697594819615062d-02, & -5.5194330231005480228d-04/ x = Abs(arg) If(x THO, 1:THO keypj_INI = gauge_THO ! PNP: number of gauge points iproj_INI = projection_THO ! projecting on different nucleus npr1pj_INI = dN_THO ! its neutron number npr2pj_INI = dZ_THO ! its proton number ! switch_on_temperature = set_temper_THO ! switches on temperature mode temper = temper_THO ! value of the temperature ! ngh_INI = numGauss_THO ! number of Gauss-Hermite points for z-direction ngl_INI = numLaguerre_THO ! number of Gauss-Laguerre points for rho-direction nleg_INI = numLegendre_THO ! number of Gauss-Legendre points for Coulomb basis_HFODD_INI = HFODD_to_HFBTHO ! flag to enforce same basis as HFODD nstate_INI = nstate_THO ! total number of states in basis Parity_INI = force_parity_THO ! forces reflection symmetry IDEBUG_INI = print_time ! debug DO_FITT_INI = .False. ! calculates quantities for reg.optimization Print_HFBTHO_Namelist_INI = .True. ! Print Namelist ! If(SUM(lambda_active).Gt.0) Then icount=0 Do l=1,lambdaMax,2 If(lambda_active(l).Gt.0) icount=icount+1 End Do If(icount.Gt.0) Parity_INI=.False. End If ! Call read_UNEDF_NAMELIST(skyrme_INI,noForce) ! If functional is used, projection automaticaly switched off If(noForce.Eq.0) iproj_INI=0 !--------------------------------------------------------------------------- ! GROUND STATE BLOCKING WALKER: blocking candidates are predefined ! by the parent nucleus and we block them one by one !--------------------------------------------------------------------------- iblocase=0; bloqpdif=zero !blomax will be charged from the previous solution Do it=1,2 If(nkblocase(it,1).Ne.0.And.nkblocase(it,2).Eq.0) Then If(it.Eq.1) Then iblocase(1)=iblocase(1)+1 If(iblocase(1).Gt.blomax(1)) iblocase(1)=1 Else If(iblocase(1).Le.1) iblocase(2)=iblocase(2)+1 End If nkblo_INI(it,1)=Sign(iblocase(it),nkblocase(it,1)) nkblo_INI(it,2)=0 Else ! case of external blocking nkblo_INI(it,:)=nkblocase(it,:) Endif End Do !--------------------------------------------------------------------------- ! MANUAL BLOCKING: manualBlocking=1 in the module (ocasionaly used) ! One types which level to be blocked referencing the parent nucleus !--------------------------------------------------------------------------- !If(manualBlocking.Ne.0) Then ! Write(*,'(a,5(1pg12.4))') 'Please print the number of the neutron level to block, num=' ! Read(*,*) nkblo_INI(1,1) ! Write(*,'(a,5(1pg12.4))') 'Neutron blocked level num=',nkblo_INI(1,1) ! nkblo_INI(1,2)=0 ! Write(*,'(a,5(1pg12.4))') 'Please print the number of the proton level to block, num=' ! Read(*,*) nkblo_INI(2,1) ! Write(*,'(a,5(1pg12.4))') 'Proton blocked level num=',nkblo_INI(2,1) ! nkblo_INI(2,2)=0 !End If !-------------------------------------------------------------------- ! Calculations for 'FITS' functional (Modifies some values if needed) !-------------------------------------------------------------------- If (Trim(skyrme_INI).Eq.'FITS') Then ! DMEORDER=-1; DMELDA=0; use_cm_cor=.False.; use_TMR_pairing=0 ! HBZERO = 20.7355300000000_pr; E2CHARG = 1.4399784085965_pr CRHO(0)=-731.2227858295098_pr; CDRHO(0)= 855.6900515849785_pr; CTAU(0) = -0.5439888609059821_pr CRHO(1)= 263.7103055246761_pr; CDRHO(1)=-176.8641956040411_pr; CTAU(1) =-33.3618818665213400_pr CRDR(0)= -43.2900897553154_pr; CJ(0) = 0.0000000000000_pr; CRDJ(0) =-75.2608700482894100_pr CRDR(1)=-164.1379857135440_pr; CJ(1) = 0.0000000000000_pr; CRDJ(1) =-22.6528199648713000_pr CPV0(0)=-186.1922465962490_pr; CPV1(0) = 0.5000000000000_pr; SIGMA = 0.2987839827782357_pr CPV0(1)=-206.7464168983860_pr; CPV1(1) = 0.5000000000000_pr; CEXPAR = 0.6391295237623640_pr ! RHO_NM=0.15732716296394680_pr; E_NM=-15.80000048487058000_pr; K_NM =225.94339488338960_pr; SMASS_NM= 0.9958725808228520_pr ASS_NM=28.3483385569865900_pr; LASS_NM =40.001962979089330_pr; VMASS_NM= 1.2489999532699580_pr ! End If !-------------------------------------------------------------------- ! Run the solver in all cases EVEN/ODDS, FITS/NO-FITS !-------------------------------------------------------------------- Call HFBTHO_SOLVER !-------------------------------------------------------------------- ! Display error messages in case of problems !-------------------------------------------------------------------- If (ierror_flag.Ne.0) Then Write(lout,*) Write(lout,'(a)') ' ERRORS IN HFBTHO_SOLVER' Do i=1,ierror_flag Write(lout,'(a,i2,2x,a)') ' error_flag=',i,ierror_info(i) End Do Write(lout,*) Else Write(lout,*) Write(lout,'(a)') ' HFBTHO_SOLVER ended without errors' Write(lout,*) End If ! If (lout.Lt.lfile) Close(lfile) ! close the output ! !help !============================================================================================= ! Output variables nucname,ereslbl(1:2),eres(1:ierest) contain: ! LBL,BLKN,BLKZ,Jsi,JININ,A,N',Z,Efn,Efp,JEtot,Jbett,Jbetn,Jbetp,JQt,JQn,JQp ! JpEn,JpEp,JpDn,JpDp,JAsn,JAsp,Jrt,Jrn,Jrp,Jrc,Jht,Jhn,Jhp,Jqht,Jqhn,Jqhp, ! JKINt,JKINn,JKINp,JSO,JCDIR,JCEX,JDisn,JDisp,JV2Mn,JV2Mp,JILST,JKIND,JL, ! JECMPAV1,JECMPAV2,JECMPAV3,JA,JN,JZ,ITER,UEtot,Ubett,Ubetn,Ubetp,UQt,UQn, ! UQp,Uln,Ulp,UpEn,UpEp,UpDn,UpDp,UAsn,UAsp,Urt,Urn,Urp,Urc,Uht,Uhn,Uhp, ! Uqht,Uqhn,Uqhp,UKINT,UKINN,UKINP,USO,UCDIR,UCEX,UDisn,UDisp,UV2Mn,UV2Mp, ! UECMT,UECMN,UECMP,UROTT,UROTN,UROTP,USQUJT,USQUJN,USQUJP,UCRANT,UCRANN, ! UCRANP,UERIGT,UERIGN,UERIGP,EHFBLN,EHFB,LNbet,LNben,LNbep,LNQt,LNQn,LNQp, ! LNpEn,LNpEp,LNpDn,LNpDp,LNrt,LNrn,LNrp,LNrC,LNam2n,LNam2p,LNe2n,LNe2p, ! BlEqpN,BlDEqpN,BlOvrN,BlEqpZ,BlDEqpZ,BlOvrZ !============================================================================================= ! End Subroutine Main_Program !================================================================================================================================== !#END MAINPROGRAM !================================================================================================================================== !#START HFBTHO_SOLVER !================================================================================================================================== Subroutine HFBTHO_SOLVER !----------------------------------------------------------------------------------------------- ! Universal HFBTHO_SOLVER ! ! Axially-deformed configurational constrained and/or unconstrained Hartree-Fock-Bogoliubov ! calculations with Skyrme-like functionals and delta pairing using the Harmonic-Oscillator ! (HO), and/or Transformed HO (THO) basis with or without reflection symmetry imposed, with ! or without the Lipkin-Nogami procedure. The solver can handle all Skyrme-like functionals, ! DME-functionals, Fayans-functionals, calculate infinite nuclear matter properties, finite ! nuclei (even-even, odd-even, odd-odd), and neutron drops, isoscalar and isovector monopo- ! le FAM QRPA calculations for spherical and deformed nuclei. ! ! All necessary input variables contain the suffix _INI. Below, the complete list of these ! variables with some example values: ! ! ======== hfbtho_NAMELIST.dat ! n00_INI=20; npr1_INI=70; npr2_INI=50; kindhfb_INI=-1; inin_INI=-1 ! b0_INI=2.234776; q_INI=0.0; cdef_INI=0.0; cqad_INI=0.5; skyrme_INI='SLY4'; nkblo_INI=0 ! ILST_INI=0; keypj_INI=1; iproj_INI=0; npr1pj_INI=0; ! icou_INI=2; IDEBUG_INI=0; npr2pj_INI=0; ! Parity_INI=.False.; epsi_INI=0.00001_pr; MAX_ITER_INI=101 ! Add_Pairing_INI=.False.; DO_FITT_INI=.False.; Print_PTHO_Namelist_INI=.True. ! ! ======== from read_UNEDF_NAMELIST ! DMEORDER=-1; DMELDA=0; use_TMR_pairing=0 ! HBZERO=20.73553000000000; E2CHARG=1.4399784085965135; CRHO(0)=-933.3423749999999; CRHO(1)=830.0524855000001; ! CDRHO(0)=861.0625000000000; CDRHO(1)=-1064.2732500000; CTAU(0)=57.12868750000000; CTAU(1)=24.65673650000000; ! CRDR(0)=-76.99620312499999; CRDR(1)=15.65713512500000; CRDJ(0)=-92.25000000000000; CRDJ(1)=-30.7500000000000; ! CJ(0)=17.20961150000000; CJ(1)=64.57581250000000; CPV0(0)=-258.2000000000000; CPV0(1)=-258.2000000000000; ! CPV1(0)=0.5000000000000000; CPV1(1)=0.500000000000000; SIGMA=0.1666666666666667; CEXPAR=1.000000000000000; ! E_NM=-15.97214914144462; K_NM=229.9009644826037; SMASS_NM =1.439546988976078; RHO_NM =0.1595387567117334; ! ASS_NM =32.00430281505202; LASS_NM=45.96175148046161; VMASS_NM =1.249838547196253; ! MPI=0.6995945261023822; GA=1.290000000000000; FPI=0.4683223517486062; C1=-0.1598130000000000; ! C3 =-0.6708200000000; C4 =0.6708200000000000; CD =-2.062000000000000; CE=-0.6250000000000; ! LAMBDAX =3.547896604156107; USE_INM=.false.; USE_CM_COR =.true.; USE_DME3N_TERMS=.true.; ! USE_J2TERMS =.true.; USE_CHARGE_DENSITY=.false.; PRINT_NAMELIST=.true.; ! ! Memo: ! - inin_INI switches scratch unconstrained (inin=1,2,3) or constrained (inin=100,200,300) ! calculations. Unconstrained mode begins with a small number of constrained iterations. ! - inin_INI switches unconstrained (inin=-1,-2,-3) or constrained (inin=-100,-200,-300) ! calculations from a previous solution if the latter exists. If not, the solver sets ! inin=Abs(inin) and resumes from scratch. ! - The same holds for odd nuclei. If even-even solution for the odd nucleus does not exists ! it is calculated first. ! - Print_Screen=T/F for n00_INI=+/-: output is generated and written in thoout.dat file ! only if n00_INI>0. For n00_INI<0, the number of shells is set to abs(n00_INI) but all ! output is supressed. ! ! - At the end of the solution, the solver provides all results in the arrays ! ! nucname,ereslbl(1:2),eres(1:ierest) ! ! which contain: ! ! LBL,BLKN,BLKZ,Jsi,JININ,A,N',Z,Efn,Efp,JEtot,Jbett,Jbetn,Jbetp,JQt,JQn,JQp ! JpEn,JpEp,JpDn,JpDp,JAsn,JAsp,Jrt,Jrn,Jrp,Jrc,Jht,Jhn,Jhp,Jqht,Jqhn,Jqhp, ! JKINt,JKINn,JKINp,JSO,JCDIR,JCEX,JDisn,JDisp,JV2Mn,JV2Mp,JILST,JKIND,JL, ! JECMPAV1,JECMPAV2,JECMPAV3,JA,JN,JZ,ITER,UEtot,Ubett,Ubetn,Ubetp,UQt,UQn, ! UQp,Uln,Ulp,UpEn,UpEp,UpDn,UpDp,UAsn,UAsp,Urt,Urn,Urp,Urc,Uht,Uhn,Uhp, ! Uqht,Uqhn,Uqhp,UKINT,UKINN,UKINP,USO,UCDIR,UCEX,UDisn,UDisp,UV2Mn,UV2Mp, ! UECMT,UECMN,UECMP,UROTT,UROTN,UROTP,USQUJT,USQUJN,USQUJP,UCRANT,UCRANN, ! UCRANP,UERIGT,UERIGN,UERIGP,EHFBLN,EHFB,LNbet,LNben,LNbep,LNQt,LNQn,LNQp, ! LNpEn,LNpEp,LNpDn,LNpDp,LNrt,LNrn,LNrp,LNrC,LNam2n,LNam2p,LNe2n,LNe2p, ! BlEqpN,BlDEqpN,BlOvrN,BlEqpZ,BlDEqpZ,BlOvrZ ! ! - Standard inputs from 'hfbtho_NAMELIST.dat' ! - USer-defined functional read from 'UNEDF_NAMELIST.DAT' ! - Final solution stored to files '*.hel' and/or '*.tel' ! - Output is written to files 'thoout.dat', 'thodef.dat' and 'hodef.dat' ! - Output files *.dat may exist as 'thoout','thores','hodenp', ! 'thodenp','thodef','thoene', ! 'thoprc','dat0.1.2.3.4' ! - External accuracy pr/ipr always set in UNEDF module ! ! - n00 Number of oscillator shells ! n00>0 prints to thoout.dat & screen ! n00<0 no print at all ! n00=0 program stops (NB!) ! - b0 Oscillator Basis parameter b0>0 (If b0<0 it takes a default value) ! - beta0 Value of Basis deformation parameter ! - AN Number of neutrons N ! - AZ Number of protons Z ! - FTST' Fayance forces label ! - kind Kind of calculations 1: noLN, -1:LN ! - inin Unconstraint Iterations from peviouse solution ! -1: (from spherical *.hel or *.tel file) ! -2: (from prolate *.hel or *.tel file) ! -3: (from oblate *.hel or *.tel file) ! Unconstraint Iterations fom scratch with ! preliminary constraint at deformation Cbeta, (i): ! 1: Spherical scratch ! 2: Prolate scratch ! 3: Oblate scratch ! Constrained calculation (icstr) at Cbeta, see (i) ! 100, 200, 300 fom scratch ! -100,-200,-300 fom previouse solution ! - blNeutrons: a group responsible for blocking a particular neutron level ! The group consists of 5 numbers, e.g., for 7-[ 3, 0, 3]: 7 -1 3 0 3 ! k1 2 \times \Omega ! =0: the whole group (k) is disregarded (n0 blocking) ! >0: blocking in N+1 nucleus ! <0: blocking in N-1 nucleus ! k2 parity (+1 or -1); NB! when k2=0, the ground state walker is applied ! k3,k4,k5 Nilson quantum numbers ! - blProtons: exactly the same as (k) but for protons ! !----------------------------------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Use HFBTHO_THO Implicit None Integer(ipr) :: iw,ib,j,i,it,l,maxi0,icstr0,iterMax,icons,il,kickoff Real(pr) :: epsi0,qq,f,f1,f2,f3,r,g,g1 !------------------------------------------------------------- ! Checking consistency of input values !------------------------------------------------------------- Call check_consistency If(ierror_flag.Ne.0) Return !------------------------------------------------------------- ! Initializing all according to *_INI values !------------------------------------------------------------- Call initialize_HFBTHO_SOLVER If(ierror_flag.Ne.0) Return If(lout.Lt.lfile) Open(lfile,file='thoout.dat',status='unknown') Call Constraint_or_not(inin_INI,inin,icstr) If(ierror_flag.Ne.0) Return !------------------------------------------------------------------------- ! Loop recalculating eventually the even-even solution for an odd nucleus !------------------------------------------------------------------------- irestart=0 Do n00=Abs(n00_INI); b0=b0_INI; q=q_INI; iLST=iLST_INI; maxi=MAX_ITER_INI; npr(1)=npr_INI(1); npr(2)=npr_INI(2); npr(3)=npr(1)+npr(2); skyrme=skyrme_INI; kindhfb=kindhfb_INI keypj=keypj_INI; iproj=iproj_INI; npr1pj=npr1pj_INI; npr2pj=npr2pj_INI; nkblo=nkblo_INI; basis_HFODD=basis_HFODD_INI !------------------------------------------------------------- ! Define the set of constraints !------------------------------------------------------------- numberCons=0; kickoff=0 Do l=1,lambdaMax If(Abs(lambda_active(l)).Gt.0) numberCons = numberCons + 1 If(lambda_active(l).Lt.0) kickoff = kickoff + 1 End Do ! If(.Not.Allocated(multLag)) Allocate(multLag(1:lambdaMax)); multLag=zero If(.Not.Allocated(multLambda)) Allocate(multLambda(1:numberCons)); multLambda=0 If(.Not.Allocated(multRequested)) Allocate(multRequested(0:lambdaMax)); multRequested=zero ! icons=0 Do l=1,lambdaMax If(Abs(lambda_active(l)).Gt.0) Then icons=icons+1 multLambda(icons)=lambda_values(l) End If multRequested(l) = expectation_values(l) End Do !------------------------------------------------------------- ! Blocking !------------------------------------------------------------- Do it=1,2 If(nkblo(it,1).Ne.0) Then If(nkblo(it,1).Gt.0) Then ! particle state npr(it)=npr(it)+1 iparenti(it)=-1 Else ! hole state npr(it)=npr(it)-1 iparenti(it)=+1 End If nkblo(it,1)=Abs(nkblo(it,1)) If(nkblo(it,2).Eq.0) Then ! ground state walker keyblo(it)=keyblo(it)+1 !nkblo(it,1) If(keyblo(it).Eq.blomax(it)) irestart=0 Else irestart=0 End If End If End Do !------------------------------------------------------------- ! HFB+HO calculations !------------------------------------------------------------- If(ILST.Le.0) Then icacou=0; icahartree=0 Call preparer(.True.) If(ierror_flag.Ne.0) Return Call inout(1) If(ierror_flag.Ne.0) Return !------------------------------------------------------------- ! Preliminary constrained calculations !------------------------------------------------------------- If(kickoff.Gt.0.And.icstr.Eq.0) Then icstr0=icstr; epsi0=epsi; ! remember accuracy icstr=1 ! constraint true epsi=1.0_pr ! small accuracy iterMax = maxi; maxi = 10 numberCons=0 Do l=1,lambdaMax If(Abs(multRequested(l)).Gt.1.D-14) Then numberCons=numberCons+1 multLambda(numberCons)=lambda_values(l) End If End Do Do iw=lout,lfile If(Parity) Then Write(iw,'(/,a,i3,a,i2,a,/)') ' ### INITIAL STAGE(constrained calculations, reflection symmetry used)' Else Write(iw,'(/,a,i3,a,i2,a,/)') ' ### INITIAL STAGE(constrained calculations, no reflection symmetry used)' End If End Do Call iter(.True.) ! small constraint iterations If(ierror_flag.Ne.0) Return icstr=icstr0; epsi=epsi0 maxi = iterMax numberCons=0 End If !------------------------------------------------------------- ! REGULAR HFB+HO ITERATIONS !------------------------------------------------------------- Do iw=lout,lfile If(Parity) Then Write(iw,'(/,a,i3,a,i2,a,/)') ' ### REGULAR STAGE (reflection symmetry imposed)' Else Write(iw,'(/,a,i3,a,i2,a,/)') ' ### REGULAR STAGE (no reflection symmetry imposed)' End If End Do Call iter(.True.) If(ierror_flag.Ne.0) Return Call resu(1) If(ierror_flag.Ne.0) Return End If !! write LST function on disk !Open(unit=66,file='LST.dat',status='unknown') !Write(66,'("#",15X,"R",20X,"f(R)",20X,"f^(1)",20X,"f^(2)",20X,"f^(3)")') !Do il=1,170 ! qq=Real(il-1)/10.0_pr*1.0_pr ! If(il.Eq.1) Call thofun(0,g,f,f1,f2,f3,g1,.True.,.True.) ! Call thofun(1,qq,f,f1,f2,f3,r,.False.,.True.) ! Write(66,'(6E24.10)') r,qq,f1,f2,f3 !End Do !Close(66) !------------------------------------------------------------- ! HFB+THO calculations from HFB+HO !------------------------------------------------------------- If(ILST.Lt.0) Then ILST1=1; icacou=0; icahartree=0 Call coordinateLST(.False.) ! THO basis If(ierror_flag.Ne.0) Return Call densit ! THO densities If(ierror_flag.Ne.0) Return Call field ! Nuclear fields If(ierror_flag.Ne.0) Return Call iter(.True.) ! HFB+THO iterations If(ierror_flag.Ne.0) Return Call resu(1) ! print/record results If(ierror_flag.Ne.0) Return End If !------------------------------------------------------------- ! HFB+THO calculations from *.tel !------------------------------------------------------------- If(ILST.Gt.0) Then If(inin.Gt.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)= ' Forbidden iLST>0, inin>0 ' Return End If icacou=0; icahartree=0 Call preparer(.True.) If(ierror_flag.Ne.0) Return Call inout(1) ! reading HFB matrices If(ierror_flag.Ne.0) Return Call iter(.True.) ! HFB+THO iterations If(ierror_flag.Ne.0) Return Call resu(1) ! print/record results If(ierror_flag.Ne.0) Return End If !------------------------------------------------------------- ! Go for the requested blocking state in a case of odd nuclei ! if restarted due to corrupted/missing previous solution !------------------------------------------------------------- inin=-Abs(inin) If(irestart.Eq.0) Exit End Do ! End Subroutine HFBTHO_SOLVER !======================================================================= ! !======================================================================= Subroutine heading !--------------------------------------------------------------------- ! print heading to screen 'lout' and to tape thoout.dat 'lfile' !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO #if(USE_OPENMP==1) Use omp_lib #endif Implicit None Integer(ipr) :: iw,idt(8),numThreads,idThread Character(len=12) rcl(3) Character(len=50) today ! #if(USE_OPENMP==1) !$OMP PARALLEL PRIVATE(numThreads,idThread) numThreads = omp_get_num_threads() idThread = omp_get_thread_num() If (idThread .Eq. 0) Then Write(lout,'("Multi-threading framework with OpenMP:",i2," threads/task")') numThreads End If !$OMP END PARALLEL #endif Call Date_and_time(rcl(1),rcl(2),rcl(3),idt) Write(today,'(a,i2,a,i2,a,i4,a,i2,a,i2,a)')'(',idt(2),'/',idt(3),'/',idt(1),', ',idt(5),':',idt(6),')' Do iw=lout,lfile Write(iw,'(a)') Write(iw,'(a)') ' =======================================' Write(iw,'(a,i2,a)') ' FORTRAN 95 CODE (KIND=',pr,') ' Write(iw,'(a,a)') ' Version: ',Version Write(iw,'(a)') ' =======================================' Write(iw,'(a)') ' AXIALLY DEFORMED CONFIGURATIONAL ' Write(iw,'(a)') ' HARTREE-FOCK-BOGOLIUBOV CALCULATIONS' Write(iw,'(a)') ' WITH ' Write(iw,'(a)') ' UNEDF AND DELTA PAIRING ' Write(iw,'(a)') ' USING ' Write(iw,'(a)') ' HARMONIC-OSCILLATOR ' Write(iw,'(a)') ' AND/OR ' Write(iw,'(a)') ' TRANSFORMED HARMONIC-OSCILLATOR ' Write(iw,'(a)') ' BASIS ' Write(iw,'(a)') ' --- ' Write(iw,'(a)') ' v1.66 (2005):, ' Write(iw,'(a)') ' Stoitsov,Dobaczewski,Nazarewicz,Ring, ' Write(iw,'(a)') ' v2.00d (2012):, ' Write(iw,'(a)') ' Stoitsov,Schunck,Kortelainen ' Write(iw,'(a)') ' =======================================' Write(iw,'(a,a,a,i4,a,i3,a,i3,a)')' Nucleus: ',nucname,' (A=',npr(1)+npr(2),& ', N=',npr(1),', Z=',npr(2),')' If(Parity) Then Write(iw,'(a)') ' Reflection Symmetry Imposed ' Else Write(iw,'(a)') ' No Reflection Symmetry Imposed ' End If Write(iw,'(a,a)') ' ',today Write(iw,'(a)') ' =======================================' Write(iw,'(a)') Write(iw,'(a)') End Do End Subroutine heading !======================================================================= ! !======================================================================= Subroutine thodefh(iw1) !--------------------------------------------------------------------- ! print labels to hodef.dat or/and thodef.dat files !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: iw1 hlabels(1)='LBL'; hlabels(11)='JEtot'; hlabels(21)='JpDp'; hlabels(2)='BLKN'; hlabels(12)='Jbett'; hlabels(22)='JAsn'; hlabels(3)='BLKZ'; hlabels(13)='Jbetn'; hlabels(23)='JAsp'; hlabels(4)='Jsi'; hlabels(14)='Jbetp'; hlabels(24)='Jrt'; hlabels(5)='JININ'; hlabels(15)='JQt'; hlabels(25)='Jrn'; hlabels(6)='A'; hlabels(16)='JQn'; hlabels(26)='Jrp'; hlabels(7)='N'; hlabels(17)='JQp'; hlabels(27)='Jrc'; hlabels(8)='Z'; hlabels(18)='JpEn'; hlabels(28)='Jht'; hlabels(9)='Efn'; hlabels(19)='JpEp'; hlabels(29)='Jhn'; hlabels(10)='Efp'; hlabels(20)='JpDn'; hlabels(30)='Jhp'; ! hlabels(31)='Jqht'; hlabels(41)='JDisp'; hlabels(51)='JN'; hlabels(32)='Jqhn'; hlabels(42)='JV2Mn'; hlabels(52)='JZ'; hlabels(33)='Jqhp'; hlabels(43)='JV2Mp'; hlabels(53)='ITER'; hlabels(34)='JKINt'; hlabels(44)='JILST'; hlabels(54)='UEtot'; hlabels(35)='JKINn'; hlabels(45)='JKIND'; hlabels(55)='Ubett'; hlabels(36)='JKINp'; hlabels(46)='JL'; hlabels(56)='Ubetn'; hlabels(37)='JSO'; hlabels(47)='JECMPAV1'; hlabels(57)='Ubetp'; hlabels(38)='JCDIR'; hlabels(48)='JECMPAV2'; hlabels(58)='UQt'; hlabels(39)='JCEX'; hlabels(49)='JECMPAV3'; hlabels(59)='UQn'; hlabels(40)='JDisn'; hlabels(50)='JA'; hlabels(60)='UQp'; ! hlabels(61)='Uln'; hlabels(71)='Urp'; hlabels(81)='UKINP'; hlabels(62)='Ulp'; hlabels(72)='Urc'; hlabels(82)='USO'; hlabels(63)='UpEn'; hlabels(73)='Uht'; hlabels(83)='UCDIR'; hlabels(64)='UpEp'; hlabels(74)='Uhn'; hlabels(84)='UCEX'; hlabels(65)='UpDn'; hlabels(75)='Uhp'; hlabels(85)='UDisn'; hlabels(66)='UpDp'; hlabels(76)='Uqht'; hlabels(86)='UDisp'; hlabels(67)='UAsn'; hlabels(77)='Uqhn'; hlabels(87)='UV2Mn'; hlabels(68)='UAsp'; hlabels(78)='Uqhp'; hlabels(88)='UV2Mp'; hlabels(69)='Urt'; hlabels(79)='UKINT'; hlabels(89)='UECMT'; hlabels(70)='Urn'; hlabels(80)='UKINN'; hlabels(90)='UECMN'; ! hlabels(91)='UECMP'; hlabels(101)='UERIGT'; hlabels(111)='LNQp'; hlabels(92)='UROTT'; hlabels(102)='UERIGN'; hlabels(112)='LNpEn'; hlabels(93)='UROTN'; hlabels(103)='UERIGP'; hlabels(113)='LNpEp'; hlabels(94)='UROTP'; hlabels(104)='EHFBLN'; hlabels(114)='LNpDn'; hlabels(95)='USQUJT'; hlabels(105)='EHFB'; hlabels(115)='LNpDp'; hlabels(96)='USQUJN'; hlabels(106)='LNbet'; hlabels(116)='LNrt'; hlabels(97)='USQUJP'; hlabels(107)='LNben'; hlabels(117)='LNrn'; hlabels(98)='UCRANT'; hlabels(108)='LNbep'; hlabels(118)='LNrp'; hlabels(99)='UCRANN'; hlabels(109)='LNQt'; hlabels(119)='LNrC'; hlabels(100)='UCRANP'; hlabels(110)='LNQn'; hlabels(120)='LNam2n'; ! hlabels(121)='LNam2p'; hlabels(122)='LNe2n'; hlabels(123)='LNe2p'; hlabels(124)='BlEqpN'; hlabels(125)='BlDEqpN'; hlabels(126)='BlOvrN'; hlabels(127)='BlEqpZ'; hlabels(128)='BlDEqpZ'; hlabels(129)='BlOvrZ'; ! Write(iw1,'((1x,a,2x),6x,660(a,2x))') hlabels ! ! HELP !Do i=1,129 ! Write(iw1,'(1x,i3,a,a)',advance='NO') i,':',trim(hlabels(i)) !End Do ! 1:LBL 2:BLKN 3:BLKZ 4:Jsi 5:JININ 6:A 7:N 8:Z 9:Efn 10:Efp ! 11:JEtot 12:Jbett 13:Jbetn 14:Jbetp 15:JQt 16:JQn 17:JQp 18:JpEn 19:JpEp 20:JpDn ! 21:JpDp 22:JAsn 23:JAsp 24:Jrt 25:Jrn 26:Jrp 27:Jrc 28:Jht 29:Jhn 30:Jhp ! 31:Jqht 32:Jqhn 33:Jqhp 34:JKINt 35:JKINn 36:JKINp 37:JSO 38:JCDIR 39:JCEX 40:JDisn ! 41:JDisp 42:JV2Mn 43:JV2Mp 44:JILST 45:JKIND 46:JL 47:JECMPAV1 48:JECMPAV2 49:JECMPAV3 50:JA ! 51:JN 52:JZ 53:ITER 54:UEtot 55:Ubett 56:Ubetn 57:Ubetp 58:UQt 59:UQn 60:UQp ! 61:Uln 62:Ulp 63:UpEn 64:UpEp 65:UpDn 66:UpDp 67:UAsn 68:UAsp 69:Urt 70:Urn ! 71:Urp 72:Urc 73:Uht 74:Uhn 75:Uhp 76:Uqht 77:Uqhn 78:Uqhp 79:UKINT 80:UKINN ! 81:UKINP 82:USO 83:UCDIR 84:UCEX 85:UDisn 86:UDisp 87:UV2Mn 88:UV2Mp 89:UECMT 90:UECMN ! 91:UECMP 92:UROTT 93:UROTN 94:UROTP 95:USQUJT 96:USQUJN 97:USQUJP 98:UCRANT 99:UCRANN 100:UCRANP ! 101:UERIGT 102:UERIGN 103:UERIGP 104:EHFBLN 105:EHFB 106:LNbet 107:LNben 108:LNbep 109:LNQt 110:LNQn ! 111:LNQp 112:LNpEn 113:LNpEp 114:LNpDn 115:LNpDp 116:LNrt 117:LNrn 118:LNrp 119:LNrC 120:LNam2n ! 121:LNam2p 122:LNe2n 123:LNe2p 124:BlEqpN 125:BlDEqpN 126:BlOvrN 127:BlEqpZ 128:BlDEqpZ 129:BlOvrZ End Subroutine thodefh !======================================================================= ! !======================================================================= Subroutine thoalloc !--------------------------------------------------------------------- ! Allocates arrays at given number of oscillator shells 'n00' !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer :: ier,ib,ND ! ! number of int.points If(Parity) Then ngh=ngh_INI; ngl=ngl_INI; nleg=nleg_INI !Yesp Else ngh=2*ngh_INI; ngl=ngl_INI; nleg=nleg_INI !Nop End If ! !nbx=2*n00+1 ! maximal number of k-blocks !ntx=(n00+1)*(n00+2)*(n00+3)/6 ! max.num. p/n levels !nzx=n00 ! maximal nz-quantum number !nrx=n00/2+1 ! maximal nr-quantum number !nlx=n00 ! maximal ml-quantum number !ndx=(n00+2)*(n00+2)/4 ! maximal dim. of one k-block !nhhdim=number of nonzero HH matrix elements ! nzrlx=(nzx+1)*(nrx+1)*(nlx+1) ! phy(:,:,nzrlx) nghl=ngh*ngl ! nghl=ngh*ngl nqx=ndx*ndx; nb2x=nbx+nbx; ndx2=ndx+ndx ilnqx=ilpj*nqx; ilnghl=ilpj*nghl nhfbx=ndx+ndx; nhfbqx=nhfbx*nhfbx; nkx=ntx; ndxs=ndx*(ndx+1)/2 !----------------------------------------- !Arrays depending on gauss points !----------------------------------------- If(Allocated(xleg)) Deallocate(xleg,wleg) If(nleg.Gt.0) Allocate(xleg(nleg),wleg(nleg)) If(Allocated(xh)) Deallocate(xh,wh,xl,sxl,wl,vc & ,vhbn,vn,vrn,vzn,vdn,vsn,dvn,vhbp,vp,vrp,vzp,vdp,vsp,dvp & ,vSZFIn,vSFIZn,vSRFIn,vSFIRn,vSZFIp,vSFIZp,vSRFIp,vSFIRp & ,fl,fli,fh,fd,fp1,fp2,fp3,fp4,fp5,fp6 & ,fs1,fs2,fs3,fs4,fs5,fs6,wdcor,wdcori,cou,vDHartree,vhart00,vhart01,vhart11) Allocate(xh(ngh),wh(ngh),xl(ngl),sxl(ngl),wl(ngl),vc(nghl,nghl)) Allocate(vhbn(nghl),vn(nghl),vrn(nghl),vzn(nghl),vdn(nghl),vsn(nghl),dvn(nghl) & ,vhbp(nghl),vp(nghl),vrp(nghl),vzp(nghl),vdp(nghl),vsp(nghl),dvp(nghl) & ,vSZFIn(nghl),vSFIZn(nghl),vSRFIn(nghl),vSFIRn(nghl) & ,vSZFIp(nghl),vSFIZp(nghl),vSRFIp(nghl),vSFIRp(nghl)) Allocate(fl(nghl),fli(nghl),fh(nghl),fd(nghl),fp1(nghl),fp2(nghl),fp3(nghl) & ,fp4(nghl),fp5(nghl),fp6(nghl),fs1(nghl),fs2(nghl),fs3(nghl),fs4(nghl) & ,fs5(nghl),fs6(nghl),wdcor(nghl),wdcori(nghl),cou(nghl),vDHartree(nghl,2) & ,vhart00(nghl,nghl),vhart01(nghl,nghl),vhart11(nghl,nghl)) If(Allocated(aka)) Deallocate(aka,ro,tau,dro,dj,NABLAR,NABLAZ,SZFI,SFIZ,SRFI,SFIR) Allocate(aka(nghl,2),ro(nghl,2),tau(nghl,2),dro(nghl,2),dj(nghl,2) & ,SZFI(nghl,2),SFIZ(nghl,2),SRFI(nghl,2),SFIR(nghl,2) & ,NABLAR(nghl,2),NABLAZ(nghl,2)) !----------------------------------------- ! Arrays depending on configurations !----------------------------------------- If(Allocated(rk)) Deallocate(rk,ak,qh,qh1,ql,ql1,nz,nr,nl,ns,npar,id & ,ia,ikb,ipb,ka,kd,tb,txb,numax,ek,dk,vk,vk1,uk,vkmax,ddc,ddc1,hfb1,lcanon) Allocate(rk(nqx,nb2x),ak(nqx,nb2x),qh(0:nzx,1:ngh+1) & ,qh1(0:nzx,1:ngh+1),ql(0:nrx,0:nlx,1:ngl+1),ql1(0:nrx,0:nlx,1:ngl+1) & ,nz(ntx),nr(ntx),nl(ntx),ns(ntx),npar(ntx),id(nbx),ia(nbx),ikb(nbx),lcanon(0:nbx,2) & ,ipb(nbx),ka(nbx,2),kd(nbx,2),tb(ntx),txb(nbx),numax(0:nkx,2) & ,ek(nkx,2),dk(nkx,2),vk(nkx,2),vk1(nkx,2),uk(nkx,2),vkmax(nkx,2) & ,ddc(ndx,nkx,2),ddc1(ndx,nkx,2),hfb1(nhfbx,2)) !----------------------------------------- ! HFB Arrays !----------------------------------------- If(Allocated(erhfb)) Deallocate(erhfb,drhfb,erhfb1,drhfb1) Allocate(erhfb(nkx),drhfb(nkx),erhfb1(nkx),drhfb1(nkx)) If(Allocated(hfb)) Deallocate(hfb,zhfb,evvk,hfbcan,evvkcan) Allocate(hfb(ndx2,ndx2),zhfb(ndx2),evvk(ndx2),hfbcan(ndx,ndx),evvkcan(ndx)) If(Allocated(AN)) Deallocate(AN,ANk,PFIU,PFID,FIU,FID,FIUR,FIDR,FIUD2N,FIDD2N,FIUZ,FIDZ) Allocate(AN(nqx),ANk(nqx),PFIU(ndx),PFID(ndx),FIU(ndx),FID(ndx) & ,FIUR(ndx),FIDR(ndx),FIUD2N(ndx),FIDD2N(ndx),FIUZ(ndx),FIDZ(ndx)) !----------------------------------------- ! Optimal LAPACK storage !----------------------------------------- If(Allocated(alwork)) Deallocate(alwork,lwork) #if(SWITCH_ESSL==0) ialwork=1+6*ndx+2*ndx**2; ilwork=3+5*ndx; Allocate(alwork(ialwork),lwork(ilwork));alwork = 0.0; lwork = 1 #else ialwork=0; ilwork=5*ndx; Allocate(alwork(1),lwork(ilwork));alwork = 0.0; lwork = 0 #endif !ialwork=1; ilwork=1; !If(Allocated(alwork)) Deallocate(alwork,lwork) !Allocate(alwork(ialwork),lwork(ilwork)) !ier=0; Call DSYEVD('V','L',ndx2,hfb,ndx2,evvk,ALWORK,-1,LWORK,-1,ier) !If(ier.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='STOP: FATAL ERROR CONDITION IN DSYEVD' ! Return !End If !ialwork=Int(alwork(1)); ilwork=lwork(1) !If(Allocated(alwork)) Deallocate(alwork,lwork) !Allocate(alwork(ialwork),lwork(ilwork)) !----------------------------------------- ! Eqp, U,V !----------------------------------------- If(Allocated(RVqpN)) Deallocate(RVqpN,RVqpP,RUqpN,RUqpP,REqpN,REqpP) Allocate(RVqpN(nuv),RVqpP(nuv),RUqpN(nuv),RUqpP(nuv),REqpN(nqp),REqpP(nqp)) If(Allocated(KpwiP)) Deallocate(KpwiP,KpwiN,KqpN,KqpP) Allocate(KpwiN(nqp),KpwiP(nqp),KqpN(nqp),KqpP(nqp)) If(Allocated(fn_T)) Deallocate(fn_T,fp_T) Allocate(fn_T(nqp),fp_T(nqp)) !----------------------------------------- ! PNP ARRAYS: CONF. AND GAUGE ANGLE !----------------------------------------- If(Allocated(exp1iphy))Deallocate(ropj,taupj,dropj,djpj,akapj,coupj,pjk & ,SZFIpj,SFIZpj,SRFIpj,SFIRpj,epj,cpj,ypj,rpj,ddepj,phypj,sinphy & ,exp1iphy,exp2iphy,exp1iphym,exp2iphym) Allocate(ropj(nghl,ilpj,2),taupj(nghl,ilpj,2),dropj(nghl,ilpj,2) & ,djpj(nghl,ilpj,2),akapj(nghl,ilpj,2),coupj(nghl,ilpj),pjk(ilpj,2) & ,SZFIpj(nghl,ilpj,2),SFIZpj(nghl,ilpj,2),SRFIpj(nghl,ilpj,2) & ,SFIRpj(nghl,ilpj,2),epj(ilpj,2),cpj(nkx,ilpj,2),ypj(nkx,ilpj,2) & ,rpj(nkx,ilpj,2),ddepj(nqx,ilpj,nb2x),phypj(ilpj),sinphy(ilpj), & exp1iphy(ilpj),exp2iphy(ilpj),exp1iphym(ilpj),exp2iphym(ilpj)) !----------------------------------------- ! FIELDS INITIALIZATION (NB! optimize) !----------------------------------------- ro=zero; tau=zero; dro=zero; dj=zero; aka=zero; rk=zero vn=zero; vsn=zero; vhbn=zero; vrn=zero; vzn=zero; vdn=zero; vp=zero; vsp=zero; vhbp=zero; vrp=zero; vzp=zero; vdp=zero; dvn=zero; dvp=zero; vSFIZn=zero; vSZFIn=zero; vSFIRn=zero; vSRFIn=zero; vDHartree=zero; vSFIZp=zero; vSZFIp=zero; vSFIRp=zero; vSRFIp=zero; ! Jason If(Allocated(allhfb)) Then Do ib=1,oldnb Deallocate(allhfb(ib)%arr,allevvk(ib)%arr,allalwork(ib)%arr,alllwork(ib)%arr) End Do Deallocate (allhfb,allevvk,allalwork,alllwork) Deallocate (allIALWORK,allILWORK,allISUPPZ) End If If (Allocated(allibro)) Deallocate(allibro) ! End Subroutine thoalloc !======================================================================= ! !======================================================================= Subroutine preparer(lpr) !--------------------------------------------------------------------- ! setup routine !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Use HFBTHO_gauss Implicit None Logical :: lpr Integer(ipr) :: iw,l,icount ! If(n00.Eq.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)=' STOP: No more nuclei pass to the solver' Return End If !----------------------------------------- ! select the symbol of the nucleus !----------------------------------------- Call nucleus(1,npr(2),nucname) If(ierror_flag.Ne.0) Return !----------------------------------------- ! print headings to screen/'thoout.dat' !----------------------------------------- If(lpr) Then Call heading Call print_functional_parameters() Do iw=lout,lfile If(ierror_flag.Ne.0) Return !If(Print_HFBTHO_Namelist) Then ! Write(iw,'(100(2x,a,f15.8))') ! Write(iw,'(100(2x,a,f15.8))') 'NAMELIST CONTENT (copy/past to hfbtho_NAMELIST.dat and modify)' ! Write(iw,'(100(2x,a,f15.8))') '-------------------------------------------------------------' ! Write(iw,HFBTHO_GENERAL) ! Write(iw,HFBTHO_ITERATIONS) ! Write(iw,HFBTHO_FUNCTIONAL) ! Write(iw,HFBTHO_CONSTRAINTS) ! Write(iw,HFBTHO_BLOCKING) ! Write(iw,HFBTHO_PROJECTION) !End If End Do End If !----------------------------------------- ! pairing parameters (NB! modify later) !----------------------------------------- rho_c=0.160_pr; pwi=60.0_pr; !----------------------------------------- ! particle number as real variable !----------------------------------------- tz(1)=Real(npr(1),Kind=pr); tz(2)=Real(npr(2),Kind=pr); amas=tz(1)+tz(2) drhoi=zero !----------------------------------------- ! default combinations !----------------------------------------- chargee2=e2charg coex=-chargee2*(three/pi)**p13; cex=-0.750_pr*coex !----------------------------------------- ! hbzero from forces [hqc**2/(two*amu)] !----------------------------------------- hb0=hbzero; If (use_cm_cor) hb0=hb0*(one-one/amas) !----------------------------------------- ! basis parameter q !----------------------------------------- beta0=q; q=Exp((3.0_pr*Sqrt(5.0_pr/(16.0_pr*pi)))*beta0) !----------------------------------------- ! basis parameters b0,bp,bz !----------------------------------------- If(b0.Le.zero) Then ! define oscillator frequency from default with empirical factor 1.2, ! and set length accordingly r00=r0*amas**p13; r02=r00**2; r04=r02**2 hom=41.0_pr*amas**(-p13)*r0 b0=Sqrt(two*hbzero/hom) Else ! define oscillator frequency from user-defined length, and set default ! empirical factor accordingly hom=hqc**2/(amn*b0**2) r0=(hom/41.0_pr)*amas**(p13) r00=r0*amas**p13; r02=r00**2; r04=r02**2 End If bp=b0*q**(-one/6.0_pr); bz=b0*q**(one/3.0_pr); bpp=bp*bp ! overwrites with input from HFODD bp=bp_INI;bz=bz_INI;b0=b0_INI; bpp=bp*bp !----------------------------------------- ! constraint in terms of beta !----------------------------------------- ty20=Sqrt(5.0_pr/pi)*hom/b0**2/two !----------------------------------------- ! projection: number of grid points !----------------------------------------- keypj=Max(1,keypj); ilpj=keypj; ilpj2=ilpj**2; If(iproj.Eq.0) Then npr1pj=npr(1); npr2pj=npr(2) Else npr1pj=npr(1)+npr1pj; npr2pj=npr(2)+npr2pj End If !----------------------------------------- ! blocking window !----------------------------------------- pwiblo=Min(Max(25.0_pr/Sqrt(Real(npr(1)+npr(2),Kind=pr)),2.0_pr),8.0_pr) !----------------------------------------- ! THO !----------------------------------------- ass=zero; iasswrong=0 !----------------------------------------- ! iterations !----------------------------------------- etot=zero; varmas=zero; rms=zero; ept=-two; del=one; alast=-seven; siold=one varmasNZ=zero; pjmassNZ=zero; ass=zero; skass=zero !--------------------------------------------------------- ! statistics to screen('lout')/file('lfile') !--------------------------------------------------------- If(lpr) Then Do iw=lout,lfile Write(iw,*) Write(iw,'(a)') ' ---------------------------------------' Write(iw,'(a)') ' Characteristics of the run ' Write(iw,'(a)') ' ---------------------------------------' Write(iw,'(a,i5)') ' Output file ................: ',lfile Write(iw,'(a,2x,a2,i4)') ' Nucleus ....................: ',nucname,npr(1)+npr(2) Write(iw,'(a,i5)') ' Number of HO shells ........: ',n00 Write(iw,'(a,f20.14)') ' HO length b0 (fm) ..........: ',b0 Write(iw,'(a,f8.3,a,f8.3)') ' Basis deformation ..........: beta0=',beta0,' q=',q Write(iw,'(a,5(1x,e15.8))') ' HO: b0,1/b0,bp,bz,q ........: ',b0,one/b0,bp,bz,q Write(iw,'(a,3(1x,e15.8))') ' h**2/(2m), cmc, e**2 .......: ',hbzero,hb0,chargee2 Write(iw,'(a,2(1X,e15.8))') ' hom=f*41.0_pr*A^{-1/3}, f...: ',hom,r0 If(iLST.Eq.0) Then ! HFB+HO case only iLST1=0 Write(iw,'(a)') ' THO basis is ...............: OFF' Else ! HFB+THO case Write(iw,'(a)') ' THO basis is ...............: ON' If(iLST.Gt.0) Then ! HFB+THO only iLST1=1 If(inin.Gt.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)=' Stop: Forbidden iLST>0, inin>0 combination.' Return End If Write(iw,'(a)') ' THO parameters from tholst.wel' Else ! HFB+THO after HFB+HO iLST1=0 Write(iw,'(a)') ' HFB+THO after a HFB+HO run ' End If End If Write(iw,'(a,i5)') ' Maximal number of iterations: ',maxi Write(iw,'(a,f6.3)') ' Initial mixing parameter ...: ',xmix If(inin.Eq.1) Then Write(iw,'(a)') ' Initial w.f. ...............: from spherical scratch' End If If(inin.Eq.2) Then Write(iw,'(a)') ' Initial w.f. ...............: from prolate scratch' End If If(inin.Eq.3) Then Write(iw,'(a)') ' Initial w.f. ...............: from oblate scratch' End If If(inin.Lt.0) Then Write(iw,'(a)') ' Initial wave functions from : tape' End If Write(iw,'(a,3x,a)') ' Skyrme functional ..........: ',skyrme If(icou.Eq.0) Write(iw,'(a)') ' without Coulomb forces' If(icou.Eq.1) Write(iw,'(a)') ' with direct Coulomb force only' If(icou.Eq.2) Write(iw,'(a)') ' with direct and exchange Coulomb' If(kindhfb.Lt.0) Then Write(iw,'(a)') ' Lipkin-Nogami procedure is .: ON' Else Write(iw,'(a)') ' Lipkin-Nogami procedure is .: OFF' End If If(ilpj-1.Eq.0) Then Write(iw,'(a)') ' PAV procedure is ...........: OFF' Else Write(iw,'(a)') ' PAV procedure is ...........: ON' Write(iw,'(a,i5)') ' Number of gauge points....: ',keypj End If If(icstr.Eq.0) Then Write(iw,'(a)') ' Constraint calculation is ..: OFF' Else Write(iw,'(a)') ' Constraint calculation is ..: ON' icount=0 Do l=1,8 If(Abs(lambda_active(l)).Gt.0) Then icount=icount+1 Write(iw,'(a,i1,a,i1,a,f8.3)') ' Constraint ',icount,' .............: lambda=',l, & ' Ql=',multRequested(l) End If End Do End If If(keyblo(1).Ne.0) Then Write(iw,'(a)') ' Neutron blocking is ........: ON' End If If(keyblo(2).Ne.0) Then Write(iw,'(a)') ' Proton blocking is .........: ON' End If If(switch_on_temperature) Then Write(iw,'(a,f6.2,a)') ' Temperature T ..............: ',temper,' MeV' Else Write(iw,'(a,f6.2)') ' Temperature T ..............: 0.00 MeV' End If Write(iw,'(a,i3)') ' Restart indicator ..........: ',inin If(nbroyden.Eq.0) Then Write(iw,'(a,i3)') ' Linear mixing ..............: ',nbroyden Else Write(iw,'(a,i3)') ' Broyden mixing (#iterations): ',nbroyden End If End Do End If !----------------------------------------- ! BASIS, GAUSS POINTS, HOWF !----------------------------------------- Call gfv ! factorials If(ierror_flag.Ne.0) Return Call base0(lpr) ! basis space (calculate configurational space) If(ierror_flag.Ne.0) Return Call thoalloc ! global allocation If(ierror_flag.Ne.0) Return Call gausspoints ! GAUSS mesh points If(ierror_flag.Ne.0) Return Call base(lpr) ! oscillator configurations (set up quantum numbers) If(ierror_flag.Ne.0) Return Call gaupol(lpr) ! basis wf at gauss mesh points If(ierror_flag.Ne.0) Return ! End Subroutine preparer !==================================================================== ! !==================================================================== Subroutine coordinateLST(lpr) !------------------------------------------------------------------ ! HO/THO !------------------------------------------------------------------ Use HFBTHO_utilities Use HFBTHO Use HFBTHO_THO, Only: f01234 Implicit None Logical :: lpr Integer(ipr) :: i,il,ih If(iLST1.Eq.0) Then ! HO-basis Do il=1,ngl Do ih=1,ngh i=ih+(il-1)*ngh fh(i)=bz*xh(ih) fl(i)=bp*Sqrt(xl(il)) wdcor(i)=pi*wh(ih)*wl(il)*bz*bp*bp wdcori(i)=one/wdcor(i) End Do End Do Else ! THO basis Call f01234(.False.) If(ierror_flag.Ne.0) Return End If ! Call optHFBTHO ! optimal HO/THO combinations If(ierror_flag.Ne.0) Return ! End Subroutine coordinateLST !==================================================================== ! !==================================================================== Subroutine iter(lpr) !------------------------------------------------------------------ ! Iterations through successive diagonalisation !------------------------------------------------------------------ Use HFBTHO_utilities Use HFBTHO Implicit None Logical :: lpr Real(pr) :: assprn,delln(2) Real(pr), Save :: time Integer(ipr) :: iw,it,ite Real(pr) :: time1,time2,time3,time4,time5 !--------------------------------------------------- ! print to screen('lout')/thoout.dat('lfile') !--------------------------------------------------- Do iw=lout,lfile If(iLST.Eq.0) Then Write(iw,'(a,f7.3,4(a,i3),a)') & ' |HFB+HO> iterations(b0=',b0,', Nsh=',n00, & ', inin=',inin,', N=',npr(1),', Z=',npr(2),')...' Else If(iLST1.Eq.0.Or.iasswrong(3).Ne.0) Then If(iasswrong(3).Ne.0) Then Write(iw,'(a,f7.3,a,i3,a)') & ' |HFB+THO substituted by HFB+HO> iterations (b0=', & b0,', Nsh=',n00,')...' Else Write(iw,'(a,f7.3,a)')' towards |hfb+tho> iterations...' Write(iw,'(a,f7.3,a)') Write(iw,'(a,f7.3,a,i3,a)') & ' |Preliminary HFB+HO> iterations (b0=',b0,', Nsh=',n00,')...' End If Else If(itass.Eq.1) Then Write(iw,'(2(a,f7.3),a,i3,a)') & ' |HFB+THO> iterations(b0=',b0,', neutron density decay=', & decay,', Nsh=',n00,')...' Else Write(iw,'(2(a,f7.3),a,i3,a)') & ' |HFB+THO> iterations(b0=',b0,', proton density decay=', & decay,', Nsh=',n00,')...' End If End If End If Write(iw,1) Write(iw,'(20(a))') ' i',' si ',' mix ',' beta', & & ' Etot ',' A ',' rn',' rp ',' En', & & ' Dn',' Ep',' Dp',' Ln ',' Lp ', & & ' time ' Write(iw,1) 1 Format(2x,130('-')) End Do !--------------------------------------------------------------------- ! main hfb iteration loop !--------------------------------------------------------------------- iError_in_HO=0; iError_in_THO=0; time=0.0_pr; time5=0.0_pr Do ite=1,maxi Call Cpu_time(time1) ! iiter=ite ! If (lpr.Or.iiter.Eq.1) Then assprn=ass(1); If(assprn.Gt.ass(2)) assprn=-ass(2) ! protons come with '-' delLN=del; If(kindhfb.Lt.0) delLN=del+ala2 ! LN case ! during iterations print Do iw=lout,lfile If(Max(Abs(drhoi(1)),Abs(drhoi(2))).Gt.1.0D-10) Then !Write(*,*) ' WARNING! Int(Dro)=',Max(Abs(drhoi(1)),Abs(drhoi(2))) End If Write(iw,2) iiter,bbroyden,si,xmix,bet,etot,varmas,rms(1),rms(2),ept(1),delLN(1), & ept(2),delLN(2),alast(1),alast(2),time End Do End If !------------------------------------------------- ! HFBDIAG !------------------------------------------------- If(IDEBUG.Gt.0) Call Cpu_time (time3) Do it=itmin,itmax Call hfbdiag(it,0) ! hfb diagonalization with minimal canonical If(ierror_flag.Ne.0) Return End Do If(Print_Screen.And.IDEBUG.Gt.0) Then Call Cpu_time (time4) Write(*,*) ' Time in hfbdiag:',time4-time3,' seconds' End If !------------------------------------------------- ! EXPECT, DENSIT, COULOMB, FIELD, GAMDEL !------------------------------------------------- Call expect(.False.) ! expectation values If (numberCons.Gt.0) Call getLagrange(ite) ! new Lagrange parameters for constraints If(ierror_flag.Ne.0) Return Call field ! new fields If(ierror_flag.Ne.0) Return Call gamdel ! hf-matrix If(ierror_flag.Ne.0) Return !------------------------------------------------- ! Dumping control (old linear mixing) !------------------------------------------------- xmix0=0.1 !original 0.1 If(si.Lt.siold) Then xmix=Min(xmax,xmix * 1.130_pr); !old value 1.13 Else xmix=xmix0 End If siold=si !------------------------------------------------- ! time per iteration !------------------------------------------------- Call Cpu_time(time2) time=time2-time1; time5=time5+time !------------------------------------------------- ! Solution is OK within the iteration limit !------------------------------------------------- If(iiter.Ge.2.And.si.Lt.epsi) Then If(iLST1.Eq.0) Then iError_in_HO=0 Else iError_in_THO=0 End If ! iteration interrupted print If(.Not.lpr) Then delLN=del; If(kindhfb.Lt.0) delLN=del+ala2 Do iw=lout,lfile Write(iw,3) iiter,bbroyden,si,xmix,bet,etot,varmas,rms(1),rms(2),ept(1),delLN(1), & ept(2),delLN(2),alast(1),alast(2),time !Max(Abs(drhoi(1)),Abs(drhoi(2))) Write(iw,'(a,f8.3,a)') ' Total CPU time=',time5/60.0_pr,' minutes' End Do End If ! converged print Do iw=lout,lfile Write(iw,4) iiter,si,iError_in_HO,iError_in_THO Write(iw,'(a,f8.3,a)') ' Total CPU time=',time5/60.0_pr,' minutes' End Do iiter=iiter+1 Return End If !------------------------------------------------- ! Slow convergence and lambda >0 (stop iterations) !------------------------------------------------- If(iiter.Ge.1000.And.(alast(1).Gt.zero.Or.alast(2).Gt.zero)) Exit ! End Do ! ite iiter=iiter+1 !------------------------------------------------- ! Solution interrupted due to iterations limit !------------------------------------------------- If(iLST1.Eq.0) Then iError_in_HO=-1 Else iError_in_THO=-1 End If delLN=del; If(kindhfb.Lt.0) delLN=del+ala2 ! iterations limit print Do iw=lout,lfile Write(iw,2) iiter,bbroyden,si,xmix,bet,etot,varmas,rms(1),rms(2),ept(1),delLN(1), & ept(2),delLN(2),alast(1),alast(2),Max(Abs(drhoi(1)),Abs(drhoi(2))) Write(iw,5) iiter,si,iError_in_HO,iError_in_THO Write(iw,'(a,f8.3,a)') ' Total CPU time=',time5/60.0_pr,' minutes' End Do !------------------------------------------------- 2 Format(i4,a,1x,f12.8,f5.2,f7.3,f13.6,1x,f6.1,2(f8.3),' | ',4(f8.3),' | ',20(f8.3)) 3 Format(2x,130('-'),/,' * iteration interrupted after',i4,' steps si=',f17.10,' ho=',i3,' tho=',i3,/,2x,130('-')) 4 Format(2x,130('-'),/,' * iteration converged after',i4,' steps si=',f17.10,' ho=',i3,' tho=',i3,/,2x,130('-')) 5 Format(2x,130('-'),/,' * iterations limit interrupt after',i4,' steps si=',f17.10,' ho=',i3,' tho=',i3,/,2x,130('-')) !------------------------------------------------- End Subroutine iter !==================================================================== ! !==================================================================== Subroutine hfbdiag(it,icanon) !------------------------------------------------------------------ ! Skyrme-HFB diagonalization in axial HO/THO basis !------------------------------------------------------------------ Use HFBTHO_utilities Use HFBTHO #if(USE_OPENMP==1) Use omp_lib #endif Implicit None Logical :: lpr_pwi,norm_to_improve Character(Len=1) :: char1,char2,char3 Integer(ipr) :: iw,it,i0,icanon,ibiblo,ier,i,j,k,k0,kl,lc,ib,nd, & nhfb,n1,n2,kaib,m,ndk,nd1,nd2,kdib,k1,k2,id1,id2, & n12,n21,ntz,nhhph,nhhpp,ibro,ibroib,i_uv,i_eqp,jj,& tid,IL,IU,NUMFOU,jlwork,jalwork,ldw,ldi,ii Real(pr) :: al,al2,emin,hla,dla,pn,eqpe,ela,enb,enb1,ekb, & s1,s2,s3,alnorm,sitest,fac1,fac2,fT,exponent, & VL,VU,ABSTOL,buffer Integer(ipr), Pointer :: KpwiPo(:),KqpPo(:) Real(pr), Pointer :: EqpPo(:),VqpPo(:),UqpPo(:),f_T(:) Integer(ipr), Allocatable :: ISUPPZ(:),lwork_p(:) Real(pr), Allocatable :: alwork_p(:),eigenv(:),eigenf(:,:),hfbmat(:,:) Real(pr), External :: DLAMCH ! If (IDEBUG.Eq.1) Call get_CPU_time('hfbdiag',0) ! If(it.Eq.1) Then EqpPo=>REqpN; VqpPo=>RVqpN; UqpPo=>RUqpN; KpwiPo=>KpwiN; KqpPo=>KqpN; f_T=>fn_T Else EqpPo=>REqpP; VqpPo=>RVqpP; UqpPo=>RUqpP; KpwiPo=>KpwiP; KqpPo=>KqpP; f_T=>fp_T End If KpwiPo=0; KqpPo=0; f_T=zero ! nhhph=(it-1)*nhhdim; nhhpp=(it+1)*nhhdim If(.Not. Allocated(allhfb)) Then oldnb = nb ! for destroying data structures in next computation Allocate(allhfb((nb)),allevvk((nb)),allalwork((nb)),alllwork((nb)),allIALWORK(nb),allILWORK(nb)) Allocate(allISUPPZ(nb)) Do ib=1,nb nhfb=2*id(ib) Allocate(allhfb(ib)%arr(1:nhfb,1:nhfb)) Allocate(allevvk(ib)%arr(1:nhfb)) !jalwork=1+6*nhfb+2*nhfb**2; allIALWORK(ib)=jalwork ! DSYEVD !jlwork=3+5*nhfb; allILWORK(ib)=jlwork ! DSYEVD #if(SWITCH_ESSL==0) jalwork=26*nhfb; allIALWORK(ib)=jalwork ! DSYEVR jlwork=10*nhfb; allILWORK(ib)=jlwork ! DSYEVR #else jalwork=1; allIALWORK(ib)=jalwork ! DSYEVX jlwork=5*nhfb; allILWORK(ib)=jlwork ! DSYEVX #endif Allocate(allalwork(ib)%arr(1:jalwork)) Allocate(alllwork(ib)%arr(1:jlwork)) Allocate(allISUPPZ(ib)%arr(1:2*nhfb)) ! DSYEVR End Do End If ! ABSTOL=2.0_pr*DLAMCH('S') ! If (.Not. Allocated(allibro)) Then Allocate(allibro(1:NB)) allibro(1)=0 Do ib=2,NB allibro(ib) = allibro(ib-1) + (ID(ib-1)*(ID(ib-1)+1)/2) End Do End If ! !------------------------------------------------------------------ ! Loop the internal normalization !------------------------------------------------------------------ !sitest=Max(Min(0.10_pr,si*0.010_pr),0.000010_pr) sitest=Min(0.10_pr,si*0.010_pr) norm_to_improve=.True.; inner(it)=-1; sumnz(it)=one Do While(norm_to_improve) ! inner(it)=inner(it)+1 ! If(Abs(sumnz(it)).Lt.sitest.Or.inner(it).Eq.20) norm_to_improve=.False. ! sumnz(it)=zero; entropy(it)=zero; v2min(it)=one; Dispersion(it)=zero ! kl=0; emin=1000.0_pr; al=ala(it) ! ! blocking If(iparenti(it).Eq.0) blomax(it)=0 blo123d(it)=0; blok1k2d(it)=0; blocanon(it)=0; ibiblo=bloblo(keyblo(it),it) !------------------------------------------------------------------ ! Runs over blocks !------------------------------------------------------------------ i_uv=0; i_eqp=0 lc=0; lcanon(0,it)=0; klmax=0 !$OMP Parallel Default(None) & !$OMP& SHARED(nb,id,ia,it,nbx,allibro,brin,allhfb,allevvk, & !$OMP& allALWORK,allLWORK,allIALWORK,allILWORK,nhhph,nhhpp,al, & !$OMP& zhfb,ndx2,allISUPPZ,ABSTOL) & !$OMP& PRIVATE(ib,nd,nhfb,i0,m,ibro,n1,nd1,n2,nd2,hla,dla,ier,tid,char1,char2, & !$OMP& NUMFOU,IL,IU,VL,VU,eigenf,eigenv,hfbmat,ISUPPZ,alwork_p,lwork_p, & !$OMP& ldw,ldi,char3,jalwork,jlwork) #if(USE_OPENMP==1) tid = OMP_GET_THREAD_NUM() #endif !$OMP DO SCHEDULE(DYNAMIC) Do ib=1,nb nd=id(ib); nhfb=nd+nd; i0=ia(ib); m=ib+(it-1)*nbx; ibro=allibro(ib) jalwork=26*nhfb; jlwork=10*nhfb allhfb(ib)%arr(1:nhfb,1:nhfb)=0.0_pr; allevvk(ib)%arr(1:nhfb)=0.0_pr allALWORK(ib)%arr(1:jalwork)=0.0_pr; allLWORK(ib)%arr(1:jlwork)=0; allISUPPZ(ib)%arr(1:2*nhfb)=0 !------------------------------------------------------------------ ! hfb-matrix !------------------------------------------------------------------ Allocate(hfbmat(nhfb,nhfb)) Do n1=1,nd nd1=n1+nd Do n2=1,n1 nd2=n2+nd; ibro=ibro+1 hla=brin(nhhph+ibro); dla=brin(nhhpp+ibro) hfbmat(n1,n2)=hla; hfbmat(nd2,n1)=dla hfbmat(nd1,n2)=dla; hfbmat(nd1,nd2)=-hla End Do hfbmat(n1,n1) =hfbmat(n1,n1) -al hfbmat(nd1,nd1)=hfbmat(nd1,nd1)+al End Do char1='V'; char2='I'; char3='L'; NUMFOU=0 VL=0.0_pr ;VU=0.0_pr; IL=1; IU=nhfb; ldw=allIALWORK(ib); ldi=allILWORK(ib) Allocate(eigenv(nhfb)); eigenv(1:nhfb)=0.0_pr Allocate(eigenf(nhfb,nhfb)); eigenf(1:nhfb,1:nhfb)=0.0_pr Allocate(alwork_p(ldw)); Allocate(lwork_p(ldi)) #if(SWITCH_ESSL==0) ier=0; Allocate(ISUPPZ(2*nhfb)) Call DSYEVR(char1,char2,char3,nhfb,hfbmat,nhfb,VL,VU,IL,IU,ABSTOL,NUMFOU, & eigenv,eigenf,nhfb,ISUPPZ,alwork_p,ldw,lwork_p,ldi,ier) #else ier=0; Allocate(ISUPPZ(nhfb)) Call DSYEVX('V','A','L',nhfb,hfbmat,nhfb,VL,VU,IL,IU,ABSTOL,NUMFOU, & eigenv,eigenf,nhfb,alwork_p,ldw,lwork_p,ldi,ISUPPZ,ier) #endif allevvk(ib)%arr(1:nhfb) = eigenv(1:nhfb) allhfb(ib)%arr(1:nhfb,1:nhfb) = eigenf(1:nhfb,1:nhfb) If(ier.NE.0) Then Write(6,*)'The algorithm failed to compute eigenvalues.' #if(USE_OPENMP==1) Write(6,*)'I am',tid,' and I am working on array ',ib,ier #endif End If Deallocate(eigenf,eigenv,hfbmat,ISUPPZ,alwork_p,lwork_p) End Do ! ib !$OMP End Do !$OMP End Parallel Do ib=1,NB nd=id(ib); nhfb=nd+nd; i0=ia(ib); m=ib+(it-1)*nbx; ibro=allibro(ib) !------------------------------------------------------------------ ! Blocking !------------------------------------------------------------------ ! external blocking If(iiter.Eq.1.And.inner(it).Eq.0) Then If(iparenti(it).Ne.0.And.keyblo(it).Eq.0) Then ! eventually charging ! keyblo(it)=1 ! bloblo(keyblo(it),it)=ib ! blo123(keyblo(it),it)=requested level (k0) Call requested_blocked_level(ib,it) If(ierror_flag.Ne.0) Return ibiblo=bloblo(keyblo(it),it) End If End If ! general blocking k0=0 If(ibiblo.Eq.ib) Then If(iiter.Eq.1.And.inner(it).Eq.0) Then ! blocked level as in the even-even nucleus k0=blo123(keyblo(it),it); ndk=k0+nd Do n2=1,nd nd2=n2+nd hfb1(n2,it)=allhfb(ib)%arr(n2,ndk) !U hfb1(nd2,it)=allhfb(ib)%arr(nd2,ndk) !V End Do ! number of states in the block to be tested blocross(it)=Min(blomax(it)+10,nd) End If ! overlap between new and old blocked levels s3=zero Do n1=1,blocross(it) ndk=n1+nd; s1=zero Do n2=1,nd nd2=n2+nd s1=s1+Abs(hfb1(nd2,it)*allhfb(ib)%arr(nd2,ndk)) !VV s1=s1+Abs(hfb1(n2,it)*allhfb(ib)%arr(n2,ndk)) !UU End Do If(s1.Gt.s3) Then s3=s1; k0=n1 End If End Do blo123d(it)=k0 If(.Not.norm_to_improve) Then ! find maximal HO component ndk=k0+nd s1=zero Do n1=1,nd nd1=n1+nd hfb1(n1,it)=allhfb(ib)%arr(n1,ndk); hfb1(nd1,it)=allhfb(ib)%arr(nd1,ndk) s2=Max(s1,Abs(allhfb(ib)%arr(n1,ndk)),Abs(allhfb(ib)%arr(nd1,ndk))) If(s2.Gt.s1) Then s1=s2; i=n1+i0 ! labels in k[k1,k2] numbering End If End Do ! print blocked state Do iw=lout,lfile Write(iw,'(4x,a,2(a,i3),2x,3(a,1x,f12.8,1x),(i3,a,i3,1x),a)') & protn(it),' Blocking: block=',ib, & ' state=',k0, & ' Eqp=',allevvk(ib)%arr(k0+nd), & ' Dqpe=',allevvk(ib)%arr(k0+nd)-eqpmin(it), & ' Ovlp=',s3 & , keyblo(it),'/',blomax(it) & , tb(i) End Do ! ieresbl=6, 'BLKN','BLKZ' ereslbl(it)=tb(i) If(it.Eq.1) Then ! 'BlEqpN','BlDEqpN','BlOvrN' eresbl(1)=allevvk(ib)%arr(k0+nd); eresbl(2)=allevvk(ib)%arr(k0+nd)-eqpmin(it); eresbl(3)=s1 Else ! 'BlEqpZ','BlDEqpZ','BlOvrZ' eresbl(4)=allevvk(ib)%arr(k0+nd); eresbl(5)=allevvk(ib)%arr(k0+nd)-eqpmin(it); eresbl(6)=s1 End If End If End If !------------------------------------------------------------------ ! Run over all qp states k in the block !------------------------------------------------------------------ kaib=kl Do k=1,nd ndk=k+nd ! referent spectra pn=zero Do i=1,nd hla=allhfb(ib)%arr(i+nd,ndk)**2; pn=pn+hla End Do ! Blocking If(k.Eq.k0) Then n1=k0+nd Do i=1,nd hla=allhfb(ib)%arr(i+nd,n1)**2; dla=allhfb(ib)%arr(i,n1)**2; pn=pn-half*(hla-dla) End Do End If eqpe=allevvk(ib)%arr(nd+k); ela=eqpe*(one-two*pn) enb=ela+al; ekb=Sqrt(Abs(eqpe**2-ela**2)) i_eqp=i_eqp+1 !------------------------------------------------------------------ ! cut-off condition: energy pwi + Fermi cut-off function !------------------------------------------------------------------ exponent=Huge(1.0_pr) If(Abs(100.0_pr*(enb-pwi)).Lt.Log(Huge(1.0_pr))) exponent=Exp(100.0_pr*(enb-pwi)) If(basis_HFODD) Then lpr_pwi=enb.Le.pwi !jacek sharp cut off for hfodd Else lpr_pwi=enb.Le.pwi.Or.Abs(one/(one+exponent)).Gt.cutoff_tol End If !------------------------------------------------------------------ ! Remember the whole qp solution !------------------------------------------------------------------ If(.Not.norm_to_improve) Then EqpPo(i_eqp)=eqpe ! Eqp_k If(lpr_pwi) KqpPo(kl+1)=i_eqp ! below pwi otherwise zero If(lpr_pwi) KpwiPo(kl+1)=i_uv ! below pwi otherwise zero Do n2=1,nd nd2=n2+nd; i_uv=i_uv+1 UqpPo(i_uv)=allhfb(ib)%arr(n2,ndk) ! U_ak VqpPo(i_uv)=allhfb(ib)%arr(nd2,ndk) ! V_ak End Do End If !------------------------------------------------------------------ ! Define Fermi-Dirac occupations !------------------------------------------------------------------ fT=zero If(switch_on_temperature.And.temper.Gt.1.D-12) Then fT = half*(one-Tanh(half*eqpe/temper)) ! factor two comes from K>0 states only buffer = zero If(fT.Gt.zero.And.fT.Lt.one) Then buffer = two*fT*Log(fT) + two*(one-fT)*Log(one-fT) End If entropy(it) = entropy(it) - buffer f_T(i_eqp) = fT End If !------------------------------------------------------------------ ! Pairing window !------------------------------------------------------------------ If(lpr_pwi) Then kl=kl+1 !number of active states If(k0.Eq.k) blok1k2d(it)=kl !blocking: dynamic #: k[k1,k2] numbering If((eqpe.Le.emin).And.(pn.Gt.0.0001_pr)) Then !to avoid unocc at magic numbers emin=eqpe; alnorm=pn !min qpe and its occupation End If erhfb(kl)=enb; drhfb(kl)=ekb; uk(kl,it)=pn !ref.s.p. energies, deltas, occupancies sumnz(it)=sumnz(it)+two*pn+two*(one-two*pn)*fT !internal normalization End If End Do ! End k ! If(.Not.norm_to_improve) Then ! !------------------------------------------------------------------ ! Density matrices !------------------------------------------------------------------ kdib=kl-kaib; ka(ib,it)=kaib; kd(ib,it)=kdib k1=kaib+1; k2=kaib+kdib eqpe=0.0_pr Do n2=1,nd Do n1=n2,nd s1=zero; s2=zero If(k1.Le.k2) Then Do k=k1,k2 ! temperature fac1 = one; fac2 = zero If(switch_on_temperature) Then !i_eqp=KqpPo(k); fac1=one-f_T(i_eqp); fac2=f_T(i_eqp) ii=KqpPo(k); fac1=one-f_T(ii); fac2=f_T(ii) End If nd1=KpwiPo(k)+n1; nd2=KpwiPo(k)+n2 s1=s1+VqpPo(nd1)*fac1*VqpPo(nd2)+UqpPo(nd1)*fac2*UqpPo(nd2) s2=s2+UqpPo(nd1)*fac1*VqpPo(nd2)+VqpPo(nd1)*fac2*UqpPo(nd2) & +VqpPo(nd2)*fac1*UqpPo(nd1)+UqpPo(nd2)*fac2*VqpPo(nd1) End Do s1=two*s1; s2=half*s2 ! two:due to m-projection, half:due to symmetrization ! blocking If(ibiblo.Eq.ib) Then i=blok1k2d(it); id1=KpwiPo(i)+n1; id2=KpwiPo(i)+n2 s1=s1-VqpPo(id1)*VqpPo(id2)+UqpPo(id1)*UqpPo(id2) s2=s2-half*(UqpPo(id1)*VqpPo(id2)+VqpPo(id1)*UqpPo(id2)) End If End If n12=n1+(n2-1)*nd; n21=n2+(n1-1)*nd rk(n12,m)=s1; rk(n21,m)=s1 ! V V' ak(n12,m)=-s2; ak(n21,m)=-s2 !- U V', ak=half*(pairing density) hfbcan(n1,n2)=s1; allhfb(ib)%arr(n1,n2)=s1 End Do !n1 End Do !n2 !------------------------------------------------------------------ ! Canonical basis !------------------------------------------------------------------ If(k1.Le.k2) Then Call Canonical(it,icanon,k2,k1,nd,i0,lc,ib,ibiblo,m,ibro) If(ierror_flag.Ne.0) Return End If lcanon(ib,it)=lc ! End If ! End Do !ib ! If(kl.Eq.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)=' STOP: kl=zero, no states below pwi!!!' Return End If If(iparenti(it).Ne.0.And.ibiblo.Eq.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: No blocking candidate found!!!' Return End If eqpmin(it)=emin; klmax(it)=kl; sumnz(it)=sumnz(it)-tz(it) !------------------------------------------------------------------ ! Lambda search !------------------------------------------------------------------ Call ALambda(al,it,kl) If(ierror_flag.Ne.0) Return If(keyblo(it).Eq.0) Then ala(it)=al Else ala(it)=ala(it)+0.50_pr*(al-ala(it)) End If ! NB! 'alast' instead of 'al' at small pairing alast(it)=al If(Abs(ept(it)).Lt.0.0001_pr.And.(.Not.switch_on_temperature)) Then ntz=Int(tz(it)+0.1_pr); ntz=ntz/2 Do k=1,kl drhfb(k)=erhfb(k) End Do Call ord(kl,drhfb) alast(it)=drhfb(ntz) !last bound s.p. energy End If !------------------------------------------------------------------ ! THO asymptotic decay !------------------------------------------------------------------ ! density asymptotic decay \rho(r)->Exp(-ass(it)*r) ! ass(it)=2*Sqrt((E_min-\lambda)/((A-1)/A)*hbar**2/(2*m))) al2=zero If(kindhfb.Lt.0) Then al2=al+two*ala2(it)*(one-two*alnorm) ! al=al+two*ala2(it) End If al2=(emin-al2)/hb0 ! wrong asymptotic iasswrong(it)=0; If(al2.Le.zero) iasswrong(it)=1; ass(it)=two*Sqrt(Abs(al2)) ! End Do ! While(norm_to_improve) ! If (IDEBUG.Eq.1) Call get_CPU_time('hfbdiag',1) ! End Subroutine hfbdiag !======================================================================= ! !======================================================================= Subroutine ALambda(al,it,kl) !--------------------------------------------------------------------- ! Adjusting Fermi energy !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: it,i,k,kl,icze,lit,ntz,iw Real(pr), Save :: fm7=1.0d-7,fm10=1.0d-10 Real(pr) :: al,vh,xinf,xsup,esup,ez,dez,dfz,dvh,y,a,b,einf,absez,sn Real(pr) :: fT,dfT Real(pr), Pointer :: f_T(:) !------------------------------------------------- ! Fermi-Dirac occupations !------------------------------------------------- If(switch_on_temperature) Then If(it.Eq.1) Then f_T=>fn_T Else f_T=>fp_T End If End If !------------------------------------------------- ! Chemical potential without pairing !------------------------------------------------- If(CpV0(it-1).Eq.zero) Then ntz=Int(tz(it)+0.1_pr); ntz=ntz/2 Do k=1,kl drhfb(k)=erhfb(k) End Do Call ord(kl,drhfb) If (ntz.Lt.kl) Then al=half*(drhfb(ntz)+drhfb(ntz+1)) Else al=drhfb(ntz)+0.001_pr End If Return End If !------------------------------------------------- ! Chemical potential with pairing !------------------------------------------------- xinf=-1000.0_pr; xsup=1000.0_pr; esup=one; icze=0 Do lit=1,500 sn=zero;dez=zero;dfz=zero Do i=1,kl vh=zero; dvh=zero; fT=zero; dfT=zero y=erhfb(i)-al; a=y*y+drhfb(i)**2; b=Sqrt(a) ! If(switch_on_temperature.And.temper.Gt.1.D-12) Then fT =half*(one-Tanh(half*b/temper)) dfT=y/b/temper*fT*(one-fT) f_T(i)=fT Else fT =zero dfT=zero End If ! If(b.Gt.zero) vh=half*(one-y/b) ! !If(b.Lt.fm7.And.icze.Eq.1) vh=-einf/(esup-einf) !no pairing If(vh.Lt.1.D-12) vh = zero If((vh-one).Gt.1.D-12) vh = one If(b.Gt.zero) dvh=half*drhfb(i)**2/(a*b) ! D[ez,al](i) ! blocking If(i.Eq.blok1k2d(it)) Then vh=half; dvh=zero End If sn=sn+two*vh+two*(one-two*vh)*fT dez=dez+two*(one-two*fT)*dvh dfz=dfz+two*(one-two*vh)*dfT ! D[ez,al] End Do ez=sn-tz(it); absez=Abs(ez)/tz(it) dez=dez+dfz !------------------------------------------------- ! Correcting bounds !------------------------------------------------- If(ez.Lt.zero) Then xinf=Max(xinf,al); einf=ez Else xsup=Min(xsup,al); esup=ez End If If(lit.Eq.1) Then If(absez.Le.0.10_pr) Then al=al-ez Else al=al-0.10_pr*Sign(one,ez) End If Else al=al-ez/(dez+1.d-20) ! newton method End If If(xsup-xinf.Lt.fm7) icze=1 ! low/upp close If(al.Lt.xinf.Or.al.Gt.xsup) al=half*(xinf+xsup) ! mean upp/low If(absez.Le.fm10) Return End Do !------------------------------------------------- ! Low accuracy warning !------------------------------------------------- Do iw=lout,lfile Write(iw,'(a,2(e12.5,2x),a,2(2x,f8.4),a,i2)') ' Low accuracy=',sn,ez,' for N,Z=',tz,' it=',it End Do End Subroutine Alambda !========================================================================================= ! !========================================================================================= Subroutine Canonical(it,icanon,k2,k1,nd,i0,lc,ib,ibiblo,m,ibroib) !--------------------------------------------------------------------------------------- ! Canonical diagonalization !--------------------------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: it,i0,icanon,ibiblo,i,iw,k,kk,lc,ib,nd,n1,n2,m,nd1,k1,k2,n12,ier Integer(ipr) :: nhhph,nhhpp,ibro,ibroib,il,iu,NUMFOU Integer(ipr), Allocatable :: ifail(:) Real(pr) :: s1,s2,vx,h1,d1,h2,d2,ddn1,ddn2,vl,vu,ABSTOL Real(pr), Allocatable :: hh(:,:),de(:,:),ewavef(:,:) Real(pr), Pointer :: EqpPo(:),VqpPo(:),UqpPo(:) Integer(ipr), Pointer :: KpwiPo(:),KqpPo(:) Integer(ipr), Allocatable :: ISUPPZ(:) Real(pr), Allocatable :: eigenv(:),eigenf(:,:) Real(pr), External :: DLAMCH ! If(it.Eq.1) Then EqpPo=>REqpN; VqpPo=>RVqpN; UqpPo=>RUqpN; KpwiPo=>KpwiN; KqpPo=>KqpN Else EqpPo=>REqpP; VqpPo=>RVqpP; UqpPo=>RUqpP; KpwiPo=>KpwiP; KqpPo=>KqpP End If ! #if(SWITCH_ESSL==0) If(Allocated(alwork)) Deallocate(alwork,lwork) ialwork=26*nd; ilwork=10*nd Allocate(ALWORK(ialwork),LWORK(ilwork)); ALWORK = 0.0_pr; LWORK = 1 #else ialwork=0; ilwork=5*nd; Allocate(ALWORK(1),LWORK(ilwork)); ALWORK = 0.0_pr; LWORK = 0 #endif ! ABSTOL=2.0_pr*DLAMCH('S') ! If(Abs(ept(it)).Lt.0.0001_pr.And.(.Not.switch_on_temperature)) Then !------------------------------------------------------ ! No pairing => just taking the HF states !------------------------------------------------------ Do k=1,nd kk=k1+k-1; lc=lc+1 ! total number of the canonical states ddc(1:nd,lc,it)=zero; vk(lc,it)=zero ! zeros: nd could be larger then k2-k1+1 If(kk.Gt.k2) Cycle vx=zero Do i=1,nd h1=VqpPo(KpwiPo(kk)+i)**2; vx=vx+h1 End Do If (vx.Le.zero) vx=zero ! roundoff errors If (vx.Ge.one ) vx=one Do i=1,nd If(vx.Ge.half) Then ddc(i,lc,it)=VqpPo(KpwiPo(kk)+i) ! (ph) s.p. orbitals in conf.space Else ddc(i,lc,it)=UqpPo(KpwiPo(kk)+i) ! (ph) s.p. orbitals in conf.space End If End Do Dispersion(it)=Dispersion(it)+four*vx*(one-vx) ! internal P/N Dispersion If(Abs(vx-half).Le.v2min(it)) Then v2min(it)=Abs(vx-half); v2minv(it)=vx ! divergent condition lcc=lc End If vk(lc,it)=vx ! (ph) s.p. occupations v^2 !------------------------------------------------------ ! RESU only !------------------------------------------------------ If(icanon.Ne.0) Then ek(lc,it)=EqpPo(KqpPo(kk))*(one-two*vx)+ala(it) ! (ph) s.p. energies dk(lc,it)=zero ! (ph) s.p. deltas End If End Do !k Else !------------------------------------------------------ ! Pairing => calculate canonical basis !------------------------------------------------------ #if(SWITCH_ESSL==0) VL=0.0_pr; VU=0.0_pr; IL=1; IU=nd; NUMFOU=0 Allocate(ISUPPZ(2*nd)) Allocate(eigenv(nd)); eigenv(1:nd)=0.0_pr Allocate(eigenf(nd,nd)); eigenf(1:nd,1:nd)=0.0_pr ier=0; Call DSYEVR('V','A','L',nd,hfbcan,ndx,VL,VU,IL,IU,ABSTOL,NUMFOU, & eigenv,eigenf,nd,ISUPPZ,ALWORK,ialwork,LWORK,ilwork,ier) evvkcan(1:nd) = eigenv(1:nd) hfbcan(1:nd,1:nd) = eigenf(1:nd,1:nd) Deallocate(eigenv,eigenf,ISUPPZ) !ier=0; Call DSYEVD('V','L',nd,hfbcan,ndx,evvkcan,ALWORK,ialwork,LWORK,ilwork,ier) #else vl=0.0_pr; vu=0.0_pr; il=1; iu=1; m=0; abstol=0.0_pr Allocate(ifail(nd),ewavef(ndx,ndx)) ier=0; Call DSYEVX('V','A','L',nd,hfbcan,ndx,vl,vu,il,iu,abstol,m,evvkcan,ewavef, & ndx,ALWORK,ialwork,LWORK,ilwork,ifail,ier) hfbcan(1:ndx,1:ndx) = ewavef(1:ndx,1:ndx) Deallocate(ifail,ewavef) #endif ! bug in LAPACK If(ier.Gt.0) Then Do iw=lout,lfile Write(iw,*) 'FATAL ERROR CONDITION IN CANONICAL DSYEVR, ier=',ier,'(RECOVERED)' End Do Do n2=1,nd Do n1=n2,nd vx=allhfb(ib)%arr(n1,n2) hfbcan(n2,n1)=vx; hfbcan(n1,n2)=vx End Do End Do Call sdiag(ndx,nd,hfbcan,evvkcan,hfbcan,zhfb,+1) End If !------------------------------------------------------ ! Eigenvalues and wavefunctions !------------------------------------------------------ Do k=1,nd lc=lc+1 ! total number of the canonical states Do i=1,nd ddc(i,lc,it)=hfbcan(i,k) ! (ph) canon orbitals in conf.space End Do vx=evvkcan(k)*half If (vx.Le.zero) vx=zero ! roundoff errors If (vx.Ge.one ) vx=one ! blocking If(ibiblo.Eq.ib.And.vx.Gt.0.49_pr.And.vx.Le.0.51_pr) blocanon(it)=lc Dispersion(it)=Dispersion(it)+four*vx*(one-vx) ! internal P/N Dispersion If(Abs(vx-half).Le.v2min(it)) Then v2min(it)=Abs(vx-half); v2minv(it)=vx ! divergent condition lcc=lc End If vk(lc,it)=vx ! (ph) canon occupations v^2 !------------------------------------------------------ ! RESU only !------------------------------------------------------ If(icanon.Ne.0) Then ! canonical energies and deltas (no physical meaning in PNP) nhhph=(it-1)*nhhdim; nhhpp=(it+1)*nhhdim Allocate(hh(nd,nd),de(nd,nd)) ibro=ibroib Do n1=1,nd Do n2=1,n1 ibro=ibro+1 vx=brin(nhhph+ibro); hh(n2,n1)=vx; hh(n1,n2)=vx vx=brin(nhhpp+ibro); de(n2,n1)=vx; de(n1,n2)=vx End Do End Do h1=zero; d1=zero Do n2=1,nd h2=zero; d2=zero Do n1=1,nd ddn1=hfbcan(n1,k) h2=h2+ddn1*hh(n1,n2) d2=d2+ddn1*de(n1,n2) End Do ddn2=hfbcan(n2,k) h1=h1+h2*ddn2 d1=d1+d2*ddn2 End Do ek(lc,it)=h1 ! (ph) canon s.p. energies dk(lc,it)=d1 ! (ph) canon s.p. deltas Deallocate(hh,de) End If ! End Do !k End If !------------------------------------------------------ ! RESU only !------------------------------------------------------ If(icanon.Ne.0) Then !------------------------------------------------------ ! Find maximal HO components of all qp states !------------------------------------------------------ Do k=k1,k2 s1=zero Do n1=1,nd nd1=nd+n1 s2=Max(s1,Abs(VqpPo(KpwiPo(k)+n1)),Abs(UqpPo(KpwiPo(k)+n1))) If(s2.Gt.s1) Then s1=s2 vkmax(k,it)=s1 ! maximal overlap numax(k,it)=n1+i0 ! its number in k[k1,k2] numbering End If End Do End Do !------------------------------------------------------ ! Searching for possible blocking candidates !------------------------------------------------------ If(iparenti(it).Eq.0) Then n1=0 Do k=k1,k2 n1=n1+1 ! Search within |(1-2*N)*Eqpe| lover than 'pwiblo' ! The levels number n1 is 1,2,3,... for the given block ([123] numbering) If(Abs(EqpPo(KqpPo(k))-eqpmin(it)).Le.pwiblo) Then blomax(it)=blomax(it)+1 ! blocked state #, maximel # of block candidates If(blomax(it).Gt.bloall) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='Too many blocking candidates! Increase bloall and run again' Return End If bloblo(blomax(it),it)=ib ! block where to block blo123(blomax(it),it)=n1 ! state # [123] numbering blok1k2(blomax(it),it)=k ! state # k[k1,k2] numbering bloqpdif(blomax(it),it)=Abs(EqpPo(KqpPo(k))-eqpmin(it)) End If End Do End If End If ! End Subroutine Canonical !======================================================================= ! !======================================================================= Subroutine resu(irecord) !--------------------------------------------------------------------- ! prints results: single particle energies, densities, fields !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: it,iw,ib,im,m,nd,k,k0,k1,k2,j,n,imax,nhfb,irecord Real(pr) :: sum,eqpe,pn,ela,enb,ek0,vk0,ekk,delb,ovmax,s,uuvv, & dk0,skk,summ(4),vvs,vvc,enjacek Real(pr), Pointer :: EqpPo(:),VqpPo(:),UqpPo(:) Integer(ipr), Pointer :: KpwiPo(:),KqpPo(:) ! !-------------------------------------------- ! last HFB run for full canon.calculations !-------------------------------------------- Do it=itmin,itmax Call hfbdiag(it,1) ! hfb with maximal canonical If(ierror_flag.Ne.0) Return End Do !PAV Call expect(.False.) ! expectation values ! !Call coulom_test ! If(ierror_flag.Ne.0) Return Call field ! new fields If(ierror_flag.Ne.0) Return Call gamdel ! hf-matrix If(ierror_flag.Ne.0) Return ! inout(2): HFB matrices if nucleus is even-even !If(npr(1).Eq.2*(npr(1)/2).And.npr(2).Eq.2*(npr(2)/2)) Then Call inout(2) If(ierror_flag.Ne.0) Return !End If !-------------------------------------------- ! Printing densities and fields !-------------------------------------------- ! Call printLST(ro(1,1),ro(1,2)) !need fix ! Call printLST(tau(1,1),tau(1,2)) ! Call printLST(dro(1,1),dro(1,2)) ! Call printLST(dj (1,1),dj (1,2)) ! printing of fields ! Call printLST(vhb(1,1),vhb(1,2)) ! Call printLST(v (1,1),v (1,2)) ! Call printLST(vs(1,1),vs(1,2)) !-------------------------------------------- ! Printing quasiparticle states !-------------------------------------------- Do it=itmin,itmax If(it.Eq.1) Then EqpPo=>REqpN; VqpPo=>RVqpN; UqpPo=>RUqpN; KpwiPo=>KpwiN; KqpPo=>KqpN Else EqpPo=>REqpP; VqpPo=>RVqpP; UqpPo=>RUqpP; KpwiPo=>KpwiP; KqpPo=>KqpP End If ! If(Print_Screen) Then iw=lfile Write(iw,200) tit(it) Write(iw,*) ' eqp(k) -> q.p. energy ' Write(iw,*) ' e(k) -> referent s.p. energy ' Write(iw,*) ' p(k) -> occ.probability ' Write(iw,*) ' del(k) -> referent s.p. gap ' Write(iw,*) ' fermi energy alast=',alast(it) Write(iw,'(a,a)') & ' #k block# eqp(k) e(k) (1-2N)E decay p(k)', & ' del(k) overl labels' 200 Format(//,' #quasiparticle energies ',a,/,1x,32('-')) End If sum=zero Do ib=1,nb nd=id(ib); im=ia(ib); m=ib+(it-1)*nbx; nhfb=nd+nd k1=ka(ib,it)+1 k2=ka(ib,it)+kd(ib,it) If(k1.Le.k2) Then Do k=k1,k2 ! print active states only pn=uk(k,it) ! qp probabilities j=k If(pn.Gt.-1.d-14) Then ! print If signIficant pn ! main oscillator component ovmax=vkmax(k,it) ! maximal overlap imax=numax(k,it) ! its number ! printing eqpe=EqpPo(KqpPo(k)) ! qp energies skk=two*Sqrt(Abs(eqpe-ala(it))/hb0) ! qp decay ela=eqpe*(one-two*pn) enb=ela+ala(it) ! ref. s.p. energies delb=Sqrt(Abs(eqpe**2-ela**2)) ! ref. s.p. delta sum=sum+two*pn ! particle number If(Print_Screen) Then iw=lfile Write(iw,201) k,ib,eqpe,enb,(one-two*pn)*eqpe,skk,pn,delb,ovmax,tb(imax) 201 Format(i4,2x,i3,1x,f12.6,f12.6,f12.6,f12.6,2x,f12.8, & 2(2x,f7.4),' ',a13) End If End If End Do End If End Do !ib !-------------------------------------------- ! Printing canonical single particle states !-------------------------------------------- If(Print_Screen) Then iw=lfile Write(iw,'(a,i4,a,i4)') & '#all active are ',j,' q.p. states out of ',nt Write(iw,'(a,f6.1)') '#since the cut off is pwi=',pwi Write(iw,'(3a,f6.1)')'#check: number of ',tit(it),'=',sum Write(iw,100) tit(it) Write(iw,*) ' labels -> {2*omega}{parity}[nn=nz+2*nr+nl,nz,nl]' Write(iw,*) ' cqpe -> canonical q.p. energies' Write(iw,*) ' ce -> canonical s.p. energies' Write(iw,*) ' fermi energy=',alast(it) Write(iw,*) ' average cdelt=',del(it) Write(iw,'(a,a)')' k0 ceqp ce v*v', & ' u*v cdel overl labels' 100 Format(//,' #canonical s.p. energies ',a,/,1x,33('-'),//) End If k0=0 summ=zero; enjacek=zero Do ib=1,nb nd=id(ib); im=ia(ib) k1=ka(ib,it)+1; k2=ka(ib,it)+kd(ib,it) If(k1.Le.k2) Then Do k=1,nd k0=k0+1 ! for Lipkin Nogami vvs=two*Sqrt(vk(k0,it))*Sqrt(one-vk(k0,it)) !2vu vvc=two*vk(k0,it)-one !2v^2-1 summ(1)=summ(1)+vvs**2 summ(2)=summ(2)+vvs**2*vvc summ(3)=summ(3)+vvs**4 summ(4)=summ(4)+(vvs*vvc)**2 ! search for main oscillator component ovmax=zero Do n=1,nd s=Abs(ddc(n,k0,it)) !canon orbitals in conf.space If (s.Ge.ovmax) Then ovmax=s; imax=n End If End Do ! printing ek0=ek(k0,it) !canon s.p. energies enjacek=enjacek+ek0*vk(k0,it) If(ek0.Lt.pwi) Then !print up to 'pwi' vk0=vk(k0,it) !canon occupations v^2 If(vk0.Gt.-1.d-4) Then !print If signIficant v^2 dk0=-dk(k0,it) !canon s.p. deltas ekk=Sqrt((ek0-ala(it))**2+dk(k0,it)**2) !resulting cqpe uuvv=Sqrt(Abs(vk0*(one-vk0))) !resulting u*v If(Print_Screen) Then iw=lfile Write(iw,101) k0,ekk+ala(it),ek0,vk0,uuvv,dk0,ovmax,tb(im+imax) 101 Format(i4,2f12.6,2(1x,f12.8),2(2x,f7.4),' ',a13) End If End If End If End Do !k0 End If End Do !ib !-------------------------------------------- ! Lipkin-Nogami !-------------------------------------------- ssln(1,it)=summ(1) ssln(2,it)=summ(2) ssln(3,it)=summ(4)*summ(1)-summ(2)**2+summ(1)**3/4.0_pr-half*summ(3)*summ(1) If(Print_Screen) Then iw=lfile Write(iw,*) ' Sum canonical e_v*V^2_k=',two*enjacek End If End Do !it !-------------------------------------------- ! To thoout.dat, thodef.dat and hodef.dat !-------------------------------------------- If(irecord.Ne.0) Then iappend=1 Call expect(.True.) !print & record HFB+PAV results If(ierror_flag.Ne.0) Return iappend=0 Else Call expect(.True.) !print HFB+PAV results If(ierror_flag.Ne.0) Return End If ! End Subroutine resu !======================================================================= ! !======================================================================= Subroutine initialize_HFBTHO_NAMELIST Use HFBTHO_utilities Use HFBTHO Implicit None !------------------------------------ ! Namelist (default values) !------------------------------------ ! HFBTHO_GENERAL number_of_shells = 10 oscillator_length =-one basis_deformation = zero proton_number = 24 neutron_number = 26 type_of_calculation = 1 ! HFBTHO_ITERATIONS number_iterations = 100 accuracy = 1.D-5 restart_file = -1 ! HFBTHO_FUNCTIONAL functional = 'SLY4' add_initial_pairing = .False. type_of_coulomb = 2 ! HFBTHO_PAIRING user_pairing = .False. vpair_n = -300.0_pr vpair_p = -300.0_pr pairing_cutoff = 60.0_pr pairing_feature = 0.5_pr ! HFBTHO_CONSTRAINTS lambda_values = (/ 0, 0, 0, 0, 0, 0, 0, 0 /) lambda_active = (/ 0, 0, 0, 0, 0, 0, 0, 0 /) expectation_values = (/ 0.0_pr, 0.0_pr, 0.0_pr, 0.0_pr, 0.0_pr, 0.0_pr, 0.0_pr, 0.0_pr /) ! HFBTHO_BLOCKING proton_blocking = (/ 0, 0, 0, 0, 0 /) neutron_blocking = (/ 0, 0, 0, 0, 0 /) ! HFBTHO_PROJECTION switch_to_THO = 0 projection_is_on = 0 gauge_points = 1 delta_Z = 0 delta_N = 0 ! HFBTHO_TEMPERATURE set_temperature = .False. temperature = zero ! HFBTHO_DEBUG number_Gauss = 40 number_Laguerre = 40 number_Legendre = 80 compatibility_HFODD = .False. number_states = 500 force_parity = .True. print_time = 0 ! End Subroutine initialize_HFBTHO_NAMELIST !======================================================================= ! !======================================================================= !Subroutine read_HFBTHO_NAMELIST ! Use HFBTHO_utilities ! Use HFBTHO ! Implicit None ! Integer(ipr) :: ios,lnamelist=16 ! !------------------------------------ ! ! Namelist (handling) ! !------------------------------------ ! Open(lnamelist,file='hfbtho_NAMELIST.dat',DELIM='APOSTROPHE') ! 'QUOTE' ! ! ! ierror_flag = 0 ! ! ! ! General input data ! Read(UNIT=lnamelist,NML=HFBTHO_GENERAL,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_GENERAL read' ! Return ! End If ! ! ! ! Iterations ! Read(UNIT=lnamelist,NML=HFBTHO_ITERATIONS,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_ITERATIONS read' ! Return ! End If ! ! ! ! Type of functional ! Read(UNIT=lnamelist,NML=HFBTHO_FUNCTIONAL,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_FUNCTIONAL read' ! Return ! End If ! ! ! ! Characteristics of pairing ! Read(UNIT=lnamelist,NML=HFBTHO_PAIRING,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_PAIRING read' ! Return ! End If ! ! ! ! Constraints ! Read(UNIT=lnamelist,NML=HFBTHO_CONSTRAINTS,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_CONSTRAINTS read' ! Return ! End If ! ! ! ! Blocking ! Read(UNIT=lnamelist,NML=HFBTHO_BLOCKING,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_BLOCKING read' ! Return ! End If ! ! ! ! Particle number projection ! Read(UNIT=lnamelist,NML=HFBTHO_PROJECTION,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_PROJECTION read' ! Return ! End If ! ! ! ! Finite temperature ! Read(UNIT=lnamelist,NML=HFBTHO_TEMPERATURE,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_TEMPERATURE read' ! Return ! End If ! ! ! ! debug ! Read(UNIT=lnamelist,NML=HFBTHO_DEBUG,iostat=ios) ! If (ios.Ne.0) Then ! ierror_flag=ierror_flag+1 ! ierror_info(ierror_flag)='Error in HFBTHO_DEBUG read' ! Return ! End If ! ! ! Close(lnamelist) ! ! !End Subroutine read_HFBTHO_NAMELIST !======================================================================= Subroutine check_consistency !--------------------------------------------------------------------- ! Check consistency of input data !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: counter, i Real(pr) :: A, preset_inin(3) Character(30), Dimension(:) :: preset_forces(17) ! If((n00_INI.Lt.1).Or.(n00_INI.GT.50)) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("number_of_shells = ",i6," out-of-bounds: [1,50]")') & n00_INI Return End If ! If((npr_INI(1).Lt.1).Or.(npr_INI(2).Lt.1)) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("Z = ",i6," N = ",i6," out-of-bounds: (Z,N)>1")') & npr_INI(2),npr_INI(1) Return End If ! If(Abs(kindhfb_INI).Ne.1) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("type_of_calculation = ",i6," unrecognized: (-1,1)")') & kindhfb_INI Return End If ! If(epsi_INI.Lt.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("accuracy = ",e24.12," out-of-bounds: >0")') & epsi_INI Return End If ! preset_inin( 1) = 1 preset_inin( 2) = 2 preset_inin( 3) = 3 ! counter=0 Do i=1, 3 If(Abs(inin_INI).Eq.preset_inin(i)) Then counter=1 Exit End If End Do ! If(counter.Eq.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("restart_file = ",i6," unrecognized: see list in publi")') & inin_INI Return End If ! preset_forces( 1) = 'SIII' preset_forces( 2) = 'SKM*' preset_forces( 3) = 'SKP' preset_forces( 4) = 'SLY4' preset_forces( 5) = 'SLY5' preset_forces( 6) = 'SLY6' preset_forces( 7) = 'SLY7' preset_forces( 8) = 'SKI3' preset_forces( 9) = 'SKO' preset_forces(10) = 'SKX' preset_forces(11) = 'HFB9' preset_forces(12) = 'UNE0' preset_forces(13) = 'UNE1' preset_forces(14) = 'UNE2' preset_forces(15) = 'N0LO' preset_forces(16) = 'N1LO' preset_forces(17) = 'N2LO' ! counter=0 Do i=1, 17 If(Trim(skyrme_INI).Eq.Trim(preset_forces(i))) Then counter=1 Exit End If End Do ! Functional must be in preset list If(counter.Eq.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("functional = ",a30," unrecognized: see list in publi")') & skyrme_INI Return End If ! Pairing cut-off must be positive If(pwi_INI.Lt.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("pairing_cutoff = ",i4," out-of-bounds: >=0")') & pwi_INI Return End If ! Pairing cut-off must be positive If(cpv1_INI.Lt.0.0.Or.cpv1_INI.Gt.1.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("pairing_feature = ",i4," out-of-bounds: [0.0,1.0]")') & cpv1_INI Return End If ! Options for Coulomb: 0, 1, 2 If(icou_INI.Lt.0.Or.icou_INI.Gt.2) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("type_of_coulomb = ",i4," unrecognized: (0,1,2)")') & icou_INI Return End If ! Choices of basis (HO or THO): -1, 0, 1 If(Abs(iLST_INI).Gt.1) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("switch_to_THO = ",i4," unrecognized: (-1,0,1)")') & iLST_INI Return End If ! At least one gauge point if projection is required If(keypj_INI.Le.0.And.iproj_INI.Ne.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("gauge_points = ",i4," out-of-bounds: >=0")') & keypj_INI Return End If ! Number of protons must be greater than 0 for projection If((npr_INI(1)+npr1pj_INI).Lt.1.And.iproj_INI.Ne.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("delta_N = ",i4," out-of-bounds: N+dN>=1")') & npr1pj_INI Return End If ! Number of neutrons must be greater than 0 for projection If((npr_INI(2)+npr2pj_INI).Lt.1.And.iproj_INI.Ne.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("delta_Z = ",i4," out-of-bounds: Z+dZ>=1")') & npr2pj_INI Return End If ! Temperature must be positive If(temper.Lt.zero) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("temperature = ",i4," out-of-bounds: T>=0")') & temper Return End If ! Number of Gauss-Laguerre integration points between 0 and 100 If(ngh_INI.Lt.1.Or.ngh_INI.Gt.100) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("number_Gauss = ",i4," out-of-bounds: [1,100]")') & ngh_INI Return End If ! Number of Gauss-Hermite integration points between 0 and 100 If(ngl_INI.Lt.1.Or.ngl_INI.Gt.100) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("number_Laguerre = ",i4," out-of-bounds: [1,100]")') & ngl_INI Return End If ! Number of Gauss-Legendre integration points lower than 100 If(nleg_INI.Gt.100) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("number_Legendre = ",i4," out-of-bounds: [-infty,100]")') & nleg_INI Return End If ! Number of Gauss-Legendre integration points between 1 and 100 for PNP If((nleg_INI.Lt.1.Or.nleg_INI.Gt.100).And.iproj_INI.Ne.0) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("number_Legendre = ",i4," out-of-bounds: [1,100]")') & nleg_INI Return End If ! Number of basis states must be greater than 0 If(nstate_INI.Lt.1.And.basis_HFODD_INI) Then ierror_flag=ierror_flag+1 Write(ierror_info(ierror_flag),'("number_states = ",i4," out-of-bounds: >0")') & nstate_INI Return End If ! End Subroutine check_consistency !======================================================================= ! !======================================================================= Subroutine initialize_HFBTHO_SOLVER !--------------------------------------------------------------------- ! default parameters !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Real(pr) :: A !------------------------------------ ! tapes !------------------------------------ lwin=41; lwou=42; lwel=52; lres=57; lin=3 !------------------------------------ ! From Namelist or default values !------------------------------------ nstate = nstate_INI epsi = epsi_INI ! stop criteria Add_Pairing = Add_Pairing_INI ! add pairing starting from file icou = icou_INI ! coul: no-(0), dir.only-(1), plus exchange-(2) DO_FITT = DO_FITT_INI ! calculates quantities for reg.optimization IDEBUG = IDEBUG_INI ! debug Parity = Parity_INI ! reflection symmetry Print_HFBTHO_Namelist = Print_HFBTHO_Namelist_INI ! Print Namelist !--------------------------------------------------------------------- ! Pairing set by user !--------------------------------------------------------------------- If(set_pairing) Then CpV0(0)=V0n_INI CpV0(1)=V0p_INI CpV1(0)=cpv1_INI CpV1(1)=cpv1_INI pwi=pwi_INI End If !------------------------------------ ! output control !------------------------------------ !If(n00_INI.Gt.0) Then ! Print_Screen=.True. ! lfile=lout+1 ! output to screen & thoout.dat !Else Print_Screen=.False. lfile=lout ! no output to screen & thoout.dat !End If !------------------------------------ ! Pi !------------------------------------ PI=four*Atan(one) !------------------------------------ ! blocking !------------------------------------ bloblo=0; blo123=0; blok1k2=0; keyblo=0 blomax=0; nkblo=0; iparenti=0; irestart=0 blocanon=0; eqpmin=zero !------------------------------------ ! buffers !------------------------------------ eres=zero; eresu=zero; eresl=zero; eresj=zero; eresbl=zero; ereslbl=' 00[00,00,00]' !------------------------------------ ! def parameters !------------------------------------ ffdef3=Sqrt(five/(four*pi))/two ffdef4=Sqrt(117.0_pr)/(four*pi) ffdef5=Sqrt(nine/(four*pi))/eight ffdef6=Sqrt(five*pi)/three ffdef7=Sqrt(pi)/four !------------------------------------ ! former linear mixing !------------------------------------ xmix0=0.3_pr ! lowest mixing parameter (redefined later) xmix =0.3_pr ! initial mixing parameter (changes every iteration) xmax =1.0_pr ! mario !------------------------------------ ! misc (redefined later) !------------------------------------ rehfbcan=0.0_pr; depnp=0.0_pr; ala2=0.00_pr ept=-2.0_pr; del=1.0_pr; ala=-7.0_pr ala1(1)=-14.6851; ala1(2)=-3.7522; si=1.0_pr iqrpa=0; icacou=0; icacoupj=0; icahartree=0; iasswrong=0 iError_in_HO=0; iError_in_THO=0 ECMHFB=0.0_pr; ECMPAV=0.0_pr If(use_full_cm_cor) Then A = npr_INI(1) + npr_INI(2) facECM = A/(A-1.0_pr) End If entropy(:)=zero !------------------------------------ ! Saxon-Woods: von koepf und ring, z.phys. (1991) !------------------------------------ v0ws=-71.28_pr; akv=0.4616_pr; r0v=1.2334_pr; av=0.6150_pr vso=11.1175_pr; rso=1.1443_pr; aso=0.6476_pr !------------------------------------ ! fixed text !------------------------------------ tp(1)='+'; tp(2)='-'; tis(1)='n'; tis(2)='p'; tit(1)='neutrons'; tit(2)='protons ' tl(0)='s'; tl(1)='p'; tl(2)='d'; tl(3)='f'; tl(4)='g' tl(5)='h'; tl(6)='i'; tl(7)='j'; tl(8)='k'; tl(9)='l' tl(10)='m'; tl(11)='n'; tl(12)='o'; tl(13)='p'; tl(14)='q' tl(15)='r'; tl(16)='s'; tl(17)='t'; tl(18)='u'; tl(19)='v'; tl(20)='w' !------------------------------------ ! fixed parity sign !------------------------------------ tpar(1)=+1; tpar(2)=-1; !------------------------------------ ! physical constants !------------------------------------ amn=938.90590_pr amu=931.4940130_pr; r0=1.20_pr alphi=137.036020_pr; hqc=197.328910_pr !------------------------------------ ! e2 for protons (set now in elsewhere) !------------------------------------ !chargee2=hqc/alphi !chargee2=1.43997841_pr !----------------------------------- ! set the loops over particle types !----------------------------------- itmin=1 ; itmax = 2; If(npr_INI(1).Eq.0) itmin = 2 If(npr_INI(2).Eq.0) itmax = 1 !----------------------------------- ! error flag and info !----------------------------------- ierror_flag=0 ierror_info(ierror_flag)='No errors in the solver!' ! Call set_functional_parameters(skyrme_INI,.False.) !----------------------------------- ! set multipole moments units !----------------------------------- Call moments_setUnits ! End Subroutine initialize_HFBTHO_SOLVER !======================================================================= ! !======================================================================= Subroutine base0(lpr) !--------------------------------------------------------------------- ! selects HO basis configurations in cylindrical coordinates !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Logical :: lpr Integer(ipr) :: iw,k,nre,nze,ke,la,le,ip,ir,iz,il,is,Iall,ilauf,jlauf,ib,nd Integer(ipr) :: NOSCIL Real(pr), Allocatable :: e(:) Real(pr) :: hbz,hbp,ee ! If(n00.Gt.n00max) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: too large n00 versus n00max' Return End If !----------------------------------------------- ! MAXIMUM NUMBER OF THE HO SHELLS (n00,NOSCIL) ! (7,120),(8,165),(9,220),(10,286),(11,364) ! (12,455),(14,680),(16,969),(18,1330),(20,1771) !----------------------------------------------- NOSCIL=(n00+1)*(n00+2)*(n00+3)/6 !----------------------------------------------- ! count all states for n00max !----------------------------------------------- nze=n00max; nre=n00max/2; ke=n00max If(basis_HFODD) Then nze=n00; nre=n00/2; ke=n00 End If Iall=0; Do k=1,ke+1 la=k-1; le=min0(ke,k) Do ip=1,2 Do ir=0,nre Do iz=0,nze Do il=la,le Do is=+1,-1,-2 If (iz+2*ir+il.Gt.n00max) Cycle If (il+(is+1)/2.Ne.k) Cycle If (Mod(iz+il,2).Ne.ip-1) Cycle Iall=Iall+1 End Do End Do End Do End Do End Do End Do !----------------------------------------------- ! charge all energies for n00max !----------------------------------------------- Allocate(e(Iall)) hbz=two*hbzero/bz**2; hbp=two*hbzero/bp**2; Iall=0; Do k=1,ke+1 la=k-1; le=min0(ke,k) Do ip=1,2 Do ir=0,nre Do iz=0,nze Do il=la,le Do is=+1,-1,-2 If (iz+2*ir+il.Gt.n00max) Cycle If (il+(is+1)/2.Ne.k) Cycle If (Mod(iz+il,2).Ne.ip-1) Cycle Iall=Iall+1 e(Iall)=hbz*(Real(iz,Kind=pr)+half) & +hbp*(two*Real(ir,Kind=pr)+Real(il,Kind=pr)+one) End Do End Do End Do End Do End Do End Do !----------------------------------------------- ! sort energies and derive base cut-off energy !----------------------------------------------- Call ord(Iall,e); If(Iall.Gt.NOSCIL) Then EBASECUT=E(NOSCIL)+1.0D-5 Else EBASECUT=E(Iall)+1.0D-5 End If If(basis_HFODD) EBASECUT=E(nstate)+1.0D-5 Deallocate(e) !----------------------------------------------- ! calculate the actual states !----------------------------------------------- nze=n00max; nre=n00max/2; ke=n00max If(basis_HFODD) Then nze=n00; nre=n00/2; ke=n00 EndIf ib=0; ilauf=0; ndx=0; nzx=0; nrx=0; nlx=0; nqp=0; nuv=0 ! loop over k-quantum number Do k=1,ke+1 la=k-1; le=min0(ke,k) ! loop over parity If(.Not.Parity) jlauf=ilauf !Nop Do ip=1,2 If(Parity) jlauf=ilauf !Yesp Do ir=0,nre Do iz=0,nze Do il=la,le Do is=+1,-1,-2 If (iz+2*ir+il.Gt.n00max) Cycle If (il+(is+1)/2.Ne.k) Cycle If (Mod(iz+il,2).Ne.(ip-1)) Cycle ee=hbz*(Real(iz,Kind=pr)+half)& +hbp*(two*Real(ir,Kind=pr)+Real(il,Kind=pr)+one) If(ee.Lt.EBASECUT) Then ilauf=ilauf+1 nzx=Max(nzx,iz); nrx=Max(nrx,ir); nlx=Max(nlx,il) End If End Do End Do End Do End Do If(Parity) Then !Yesp If (ilauf.Gt.jlauf) Then ib=ib+1 nd=ilauf-jlauf ndx=Max(ndx,nd) nqp=nqp+nd; nuv=nuv+nd*nd End If End If End Do If(.Not.Parity) Then !Nop If(ilauf.Gt.jlauf) Then ib=ib+1 nd=ilauf-jlauf ndx=Max(ndx,nd) nqp=nqp+nd; nuv=nuv+nd*nd End If End If End Do nbx=ib; ntx=ilauf !----------------------------------------------- ! print statistics !----------------------------------------------- If(lpr) Then Do iw=lout,lfile Write(iw,*) Write(iw,'(a)') ' ---------------------------------------' Write(iw,'(a)') ' Harmonic Oscillator Basis ' Write(iw,'(a)') ' ---------------------------------------' Write(iw,'(a,2(i6,2x),a)') ' NUV, NQP: ',nuv,nqp Write(iw,'(a,2(i6,2x),a)') ' Comparison with bookkeeping spherical basis:' Write(iw,'(a,2(i6,2x),a)') ' n00: ',n00,n00, & 'Maximal number of shells' Write(iw,'(a,2(i6,2x),a)') ' nbx, 2*n00+1: ',nbx,2*n00+1, & 'Maximal number of K-blocks' Write(iw,'(a,2(i6,2x),a)') ' ntx, (n00+1)*(n00+2)*(n00+3)/6 ',ntx,(n00+1)*(n00+2)*(n00+3)/6, & 'Max.num. p/n levels' Write(iw,'(a,2(i6,2x),a)') ' nzx, n00: ',nzx,n00, & 'Maximal nz-quantum number' Write(iw,'(a,2(i6,2x),a)') ' nrx, n00/2 : ',nrx,n00/2, & 'Maximal nr-quantum number' Write(iw,'(a,2(i6,2x),a)') ' nlx, n00: ',nlx,n00, & 'Maximal ml-quantum number' Write(iw,'(a,2(i6,2x),a)') ' ndx, (n00+2)*(n00+2)/4: ',ndx,(n00+2)*(n00+2)/4, & 'Maximal dim. of one k-block' Write(iw,*) End Do End If ! End Subroutine base0 !======================================================================= ! !======================================================================= Subroutine base(lpr) !--------------------------------------------------------------------- ! set HO basis configurations in cylindrical coordinates !--------------------------------------------------------------------- Use HFBTHO Implicit None Logical :: lpr Integer(ipr) :: nze,nre,ke,ib,ilauf,jlauf,nom,nnm, & k,la,le,ip,ir,iz,il,is,nn,ND,IBX,N1,N2,iw Real(pr) :: hbz,hbp,ee ! hbz=two*hbzero/bz**2; hbp=two*hbzero/bp**2; ! nze=n00max; nre=n00max/2; ke=n00max If(basis_HFODD) Then nze=n00; nre=n00/2; ke=n00 End If ib=0; ilauf=0; nzm=0; nrm=0; nlm=0; nom=0; nnm=0 !----------------------------------------------- ! loop over k-quantum number !----------------------------------------------- Do k=1,ke+1 la=k-1; le=min0(ke,k) ! loop over parity If(.Not.Parity) jlauf=ilauf !Nop Do ip=1,2 If(Parity) jlauf=ilauf !Yesp Do ir=0,nre Do iz=0,nze Do il=la,le Do is=+1,-1,-2 If (iz+2*ir+il.Gt.n00max) Cycle If (il+(is+1)/2.Ne.k) Cycle If (Mod(iz+il,2).Ne.ip-1) Cycle ee=hbz*(Real(iz,Kind=pr)+half)& +hbp*(two*Real(ir,Kind=pr)+Real(il,Kind=pr)+one) If(ee.Lt.EBASECUT) Then ilauf=ilauf+1 If (ilauf.Gt.ntx) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: in base: ntx too small' Return End If nz(ilauf)=iz; nr(ilauf)=ir; nl(ilauf)=il; ns(ilauf)=is; npar(ilauf)=ip nn =iz+2*ir+il Write(tb(ilauf),100) 2*k-1,tp(ip),nn,iz,il 100 Format(i2,a1,'[',i2,',',i2,',',i2,']') Do iw=lout,lfile If(lpr.And.IDEBUG.Gt.10) & Write(iw,'(i4,a,i2,a,i2,a,i2,a,i2,a,i2,a,2x,a,1x,a,f14.8)') & ilauf,' nn=',nn,' nz=',iz,' nr=',ir, & ' ml=',il,' ms=',is,' /2',tb(ilauf),'e=',ee End Do nzm=Max(nzm,iz); nrm=Max(nrm,ir); nlm=Max(nlm,il) nom=Max(nom,2*k-1); nnm=Max(nnm,iz+2*ir+il) End If End Do End Do End Do End Do !----------------------------------------------- ! Block memory !----------------------------------------------- If(Parity) Then !Yesp If (ilauf.Gt.jlauf) Then ib=ib+1 ia(ib)=jlauf; id(ib)=ilauf-jlauf ikb(ib)=k; ipb(ib)=ip Write(txb(ib),'(i3,a,i2,a,a1)') ib,'. block: k=',k+k-1,'/2',tp(ip) !ir=(ib+1)/2 !Write(*,*) ib,2*k-1,'2*Omega=',2*ir - 1 Do iw=lout,lfile If(lpr.And.IDEBUG.Gt.10) Write(iw,'(/,a,i3,a,a1)')' For the above block: k=',k+k-1,'/2',tp(ip) End Do End If If(id(ib).Eq.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: in base Block Memory(1)' Return End If End If End Do ! end of ip !----------------------------------------------- ! Block memory !----------------------------------------------- If(.Not.Parity) Then !Nop If (ilauf.Gt.jlauf) Then ib=ib+1 ia(ib)=jlauf; id(ib)=ilauf-jlauf nn = nz(ilauf)+2*nr(ilauf)+nl(ilauf); ip = 2 - Mod(nn,2) ikb(ib)=k; ipb(ib)=ip Write(txb(ib),'(i3,a,i2,a,a1)') ib,'. block: k=',k+k-1,'/2',tp(ip) Do iw=lout,lfile If(lpr.And.IDEBUG.Gt.10) Write(iw,'(/,a,i3,a,a1)')' For the above block: k=',k+k-1,'/2',tp(ip) End Do End If If(id(ib).Eq.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: in base Block Memory(2)' Return End If End If End Do ! end k nb=ib; nt=ilauf !----------------------------------------------- ! broyden/linear mixing (storage) !----------------------------------------------- nhhdim=0 Do ib=1,NB ND=ID(ib) Do N1=1,ND Do N2=1,N1 nhhdim=nhhdim+1 End Do End Do End Do nhhdim2=2*nhhdim; nhhdim3=3*nhhdim; nhhdim4=4*nhhdim If(Allocated(brin)) Deallocate(brin,brout) Allocate(brin(nhhdim4+lambdaMax),brout(nhhdim4+lambdaMax)) !----------------------------------------------- ! Print statistics !----------------------------------------------- If(lpr) Then Do iw=lout,lfile Write(iw,'(a,i4)') ' Actual basis used' Write(iw,'(a,i4)') ' Number of blocks: nb .......: ',nb Write(iw,'(a,i4)') ' Number of levels: nt .......: ',nt Write(iw,'(a,i4)') ' Maximal 2*omega : nom ......: ',nom Write(iw,'(a,i4)') ' Maximal nz: nzm ......: ',nzm Write(iw,'(a,i4)') ' Maximal nr: nrm ......: ',nrm Write(iw,'(a,i4)') ' Maximal ml: nlm ......: ',nlm Write(iw,'(a,i4)') ' Maximal N=nz+2*nr+nl .......: ',nnm Write(iw,'(a,i4)') ' 2 x biggest block dim. .....: ',ndx2 Write(iw,'(a,i8)') ' Non-zero elements of h .....: ',nhhdim Write(iw,'(a,i8)') ' Number of Broyden elements .: ',nhhdim4 Write(iw,'(a,i4)') End Do End If If(nzm.Ge.n00max.Or.(nom-1)/2.Eq.n00max) Then Write(*,*) 'nzm=',nzm,' (nom-1)/2=',(nom-1)/2,' n00max=',n00max ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: Please increase n00max to have correct basis' End If End Subroutine base !======================================================================= ! !======================================================================= Subroutine gaupol(lpr) !--------------------------------------------------------------------- ! HO wave functions in cylindrical coordinates !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Logical :: lpr Real(pr) :: w0,z,x,s,s0,s1,w00,w4pii,dsq,d1,d2,d3,d4,hs0,hs1 Integer(ipr) :: ih,il,iw,ix,n,l,n1,n2 !----------------------------------------------- ! Hermite !----------------------------------------------- w4pii=pi**(-0.250_pr) Do ih=1,ngh z=xh(ih); w0=w4pii*Exp(-half*z*z) ! functions qh, qh1; norm: \sum_{ih} qh(n1,ih)*qh(n2,ih)=\delta_{n1,n2} w0 =w0*Sqrt(wh(ih)) qh(0,ih)=w0; qh(1,ih)=sq(2)*w0*z qh1(0,ih)=-w0*z; qh1(1,ih)=sq(2)*w0*(one-z*z) Do n=2,nzm qh(n,ih)=sqi(n)*(sq(2)*z*qh(n-1,ih)-sq(n-1)*qh(n-2,ih)) qh1(n,ih)=sq(n+n)*qh(n-1,ih)-z*qh(n,ih) End Do End Do !----------------------------------------------- ! Laguerre !----------------------------------------------- Do il=1,ngl x=xl(il); w00=sq(2)*Exp(-half*x) Do l=0,nlm ! functions ql, ql1; norm: \sum_{il} ql(n1,l,il)*ql(n2,l,il)=\delta_{n1,n2} w0=w00*Sqrt(half*wl(il)*x**l) ql(0,l,il)=wfi(l)*w0; ql(1,l,il)=(l+1-x)*wfi(l+1)*w0 ql1(0,l,il)=(l-x)*wfi(l)*w0; ql1(1,l,il)=(Real(l*l+l,Kind=pr) & -x*Real(l+l+3,Kind=pr)+x*x)*wfi(l+1)*w0 Do n=2,nrm dsq=sq(n)*sq(n+l); d1=Real(n+n+l-1,Kind=pr)-x d2=sq(n-1)*sq(n-1+l); d3=n+n+l-x; d4=two*dsq ql(n,l,il)=(d1*ql(n-1,l,il)-d2*ql(n-2,l,il))/dsq ql1(n,l,il)=d3*ql(n,l,il)-d4*ql(n-1,l,il) End Do End Do End Do !----------------------------------------------- ! Test accuracy for Hermite orthonormalization !----------------------------------------------- hs0=zero; hs1=two Do n1=0,nzm Do n2=0,n1 If (Mod(n1-n2,2).Eq.0) Then s=zero Do ih=1,ngh s=s+qh(n1,ih)*qh(n2,ih) End Do If(n1.Ne.n2) Then hs0=Max(s,hs0) Else hs1=Min(s,hs1) End If End If End Do End Do !----------------------------------------------- ! Test accuracy for Laguerre orthonormalization !----------------------------------------------- s0=zero; s1=two Do l=0,nlm Do n1=0,nrm Do n2=0,n1 s=zero Do il=1,ngl s=s+ql(n1,l,il)*ql(n2,l,il) End Do If(n1.Ne.n2) Then s0=Max(s,s0) Else s1=Min(s,s1) End If End Do End Do End Do !----------------------------------------------- ! print accuracy !----------------------------------------------- If(lpr) Then Do iw=lout,lfile Write(iw,'(a)') ' ---------------------------------------' Write(iw,'(a)') ' Integration Meshes ' Write(iw,'(a)') ' ---------------------------------------' Write(iw,'(a,i3)') & ' Number of Gauss-Hermite mesh points ngh ....: ',ngh Write(iw,'(a,i3)') & ' Number of Gauss-Laguerre mesh points ngl ...: ',ngl Write(iw,'(a,i3)') & ' Number of Gauss-Legendre mesh points nleg ..: ',nleg Write(iw,'(a)') & ' Integration boundaries' Write(iw,'(2(a,f12.8))') & ' Hermite - from xh(1) =',xh(1), ' to xh(ngh) =',xh(ngh) Write(iw,'(2(a,f12.8))') & ' Laguerre - From xl(1) =',xl(1), ' to xl(ngl) =',xl(ngl) If(nleg.Gt.0) Then Write(iw,'(2(a,f12.8))') & ' Legendre - From xleg(1)=',xleg(1),' to xleg(nleg)=',xleg(nleg) End If Write(iw,*) & ' Max.dev.in: Orthogonality Normalization' Write(iw,*) ' Hermite ',hs0,Abs(one-hs1) Write(iw,*) ' Laguerre ',s0,Abs(one-s1) End Do End If !----------------------------------------------- ! debug !----------------------------------------------- If (lpr.And.IDEBUG.Gt.20) Then ix=3 Do iw=lout,lfile Write(iw,*) ' nz qh(nz,ih=1,...)' Do n=0,nzm Write(iw,'(i4,3f15.8)') n,(qh(n,ih),ih=1,ix) Write(iw,'(i4,3f15.8)') n,(qh1(n,ih),ih=1,ix) Write(iw,*) ' ' End Do Do l=0,nlm Write(iw,*) ' nr ml ql(nr,l,il=1,...)' Do n=0,nrm Write(iw,'(i4,i3,3f15.8)') n,l,(ql(n,l,il),il=1,ix) Write(iw,'(i4,i3,3f15.8)') n,l,(ql1(n,l,il),il=1,ix) Write(iw,*) ' ' End Do End Do End Do !----------------------------------------------- ! Test for Hermite polynomials normalization !----------------------------------------------- Do n1=0,nzm Do n2=0,n1 If (Mod(n1-n2,2).Eq.0) Then s=zero Do ih=1,ngh s=s+qh(n1,ih)*qh(n2,ih) End Do Do iw=lout,lfile Write(iw,100) n1,n2,s End Do 100 Format(' Gauss-Hermite: n1=',i3,' n2=',i3,f20.8) End If End Do End Do !----------------------------------------------- ! Test for Laguerre polynomials normalization !----------------------------------------------- Do l=0,nlm Do n1=0,nrm Do n2=0,n1 s=zero Do il=1,ngl s=s+ql(n1,l,il)*ql(n2,l,il) End Do Do iw=lout,lfile Write(iw,101) l,n1,n2,s 101 Format(' Gauss Laguerre: l=' & ,i2,' n1=',i3,' n2=',i3,f20.8) End Do End Do End Do End Do End If ! Call coordinateLST(.False.) ! coordinate LST ! End Subroutine gaupol !======================================================================= ! !======================================================================= Subroutine FileLabels(NPRI,ININL,FILELABEL) !--------------------------------------------------------------------- ! file labels, e.g., filelabel='s070_040' !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: it,ininabs,ininl,nprt(2),NPRI(2) Character(1) :: sinin Character(3) :: snpr(2) Character(8) :: filelabel ! ininabs=iabs(ininl) If(ininabs.Eq.4.or.ininabs.Eq.400) sinin='t' If(ininabs.Eq.3.or.ininabs.Eq.300) sinin='o' If(ininabs.Eq.2.or.ininabs.Eq.200) sinin='p' If(ininabs.Eq.1.or.ininabs.Eq.100) sinin='s' ! nprt=npri Do it=itmin,itmax If(npri(it).Ne.2*(npri(it)/2)) nprt(it)=nprt(it)+iparenti(it) !iparent=-/+ means particles/holes If(nprt(it).Lt.10 ) Then Write(snpr(it),'(a2,i1)') '00',nprt(it) Else If(nprt(it).Lt.100 ) Then Write(snpr(it),'(a1,i2)') '0',nprt(it) Else Write(snpr(it),'(i3)') nprt(it) End If End If End Do ! Write(filelabel,'(a1,a3,a1,a3)') sinin,snpr(1),'_',snpr(2) ! End Subroutine FileLabels !======================================================================= ! !======================================================================= Subroutine inout(is) !--------------------------------------------------------------------- ! is=1: reads matrix elements from tape and exit ! is=2: writes matrix elements to tape and exit ! NB! if the welfile is missing or corrupt call start ! to restart calculations from scratch !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Logical :: file_exists,file_opened Integer(ipr) :: is,iw,n1,n2,nd,ib,bloall1,lambdaMax1,ierr,counterLine Character(8) :: filelabel Character(30) :: welfile Real(pr) :: tz1(2),b01,bz1,bp1,beta1,v0r(2),v1r(2),pwir Integer(ipr) :: npr1,npr11,ngh1,ngl1,n001,nt1 Integer(ipr) :: ntx1,nb1,nhhdim1,NLANSA0,NLANSA1,NZA2NRA,NZA1,NLA1 Integer(ipr) :: ID1(nbx) !==== HFBODD interface Integer(ipr) :: i,nza,nra,nla,nsa,ibasis Integer(ipr) :: ibro !==== ! label organization Call FileLabels(NPR,ININ,FILELABEL) If(ierror_flag.Ne.0) Return If(iLST1.Le.0) Write(welfile,'(a8,a4)') FILELABEL,'.hel' If(iLST1.Gt.0) Write(welfile,'(a8,a4)') FILELABEL,'.tel' ! welfile = welfile_INI If (is.Eq.1) Then !--------------------------------------------------------------------- ! read matrix elements from 'welfile' file or start from scratch !--------------------------------------------------------------------- If(inin.Gt.0) Then Call start Return End If !--------------------------------------------------------------------- ! Check status of file on disk !--------------------------------------------------------------------- file_exists=.False.; inquire(file=welfile, exist=file_exists); ierr=0 If(file_exists) Then file_opened=.False.; inquire(unit=lwin, opened=file_opened) If(file_opened) Then Close(lwin) Else End If Open(lwin,file=welfile,status='old',form='unformatted',IOSTAT=ierr) If(ierr.NE.0) Then Do iw=lout,lfile Write(iw,'(1x,a,a,a)') Write(iw,'(1x,a,a,a)') ' The file ',welfile,' could not be opened!' Write(iw,'(1x,a,a,a)') ' STARTING FROM SCRATCH WITH ININ=IABS(ININ)!' Write(iw,'(1x,a,a,a)') End Do Call start Return End If Else Do iw=lout,lfile Write(iw,'(1x,a,a,a)') Write(iw,'(1x,a,a,a)') ' The file ',welfile,' is missing!' Write(iw,'(1x,a,a,a)') ' STARTING FROM SCRATCH WITH ININ=IABS(ININ)!' Write(iw,'(1x,a,a,a)') End Do Call start Return End If !--------------------------------------------------------------------- ! Read data !--------------------------------------------------------------------- counterLine = 0 Read(lwin,ERR=100,End=100) npr11,npr1,ngh1,ngl1,n001,nb1,nt1 counterLine = counterLine+1 If(Abs(n001).Ne.Abs(n00).And.nb1.Ne.nb) go to 100 Read(lwin,ERR=100,End=100) b01,bz1,bp1,beta1,si,etot,rms,bet,xmix,v0r,v1r,pwir, & del,ept,ala,ala2,alast,tz1,varmas,varmasNZ,pjmassNZ, & ass,skass brin=zero; bbroyden='L'; !si=one; counterLine = counterLine+1 Read(lwin,ERR=100,End=100) ntx1,nb1,nhhdim1 counterLine = counterLine+1 Read(lwin,Err=100,End=100) lambdaMax1 counterLine = counterLine+1 Read(lwin,Err=100,End=100) multLag counterLine = counterLine+1 Read(lwin,ERR=100,End=100) id1 counterLine = counterLine+1 Read(lwin,ERR=100,End=100) brin counterLine = counterLine+1 ! ! Add small pairing de=de+0.1 in the no-LN ! case to prevent pairing collaps If(kindhfb.Eq.1.And.Add_Pairing) Then ibro=0 Do ib=1,NB ND=ID1(ib) I=ibro Do N1=1,ND Do N2=1,N1 I=I+1 brin(i+nhhdim2)=brin(i+nhhdim2)+0.10_pr brin(i+nhhdim3)=brin(i+nhhdim3)+0.10_pr End Do !N2 End Do !N1 ibro=i End Do !IB End If Do ib=1,NB ND=ID1(ib) Do N1=1,ND Read(lwin,ERR=100,End=100) NLANSA0,NLANSA1,NZA2NRA,NZA1,NLA1 End Do End Do counterLine = counterLine+1 ! blocking Read(lwin,ERR=100,End=100) bloall1 counterLine = counterLine+1 Read(lwin,ERR=100,End=100) bloblo,blo123,blok1k2,blomax,bloqpdif counterLine = counterLine+1 If(bloall1.Ne.bloall) go to 100 !tel If(iLST.Gt.0) Then Read(lwin,ERR=100,End=100) decay,rmm3,cmm3,amm3,bmm3,itass,iqqmax If(Allocated(fdsx)) Deallocate(fdsx,fdsy,fdsy1,fdsy2,fdsy3, & fspb0,fspc0,fspd0,fspb1,fspc1,fspd1,fspb2,fspc2,fspd2, & fspb3,fspc3,fspd3) Allocate(fdsx(iqqmax),fdsy(iqqmax),fdsy1(iqqmax), & fdsy2(iqqmax),fdsy3(iqqmax),fspb0(iqqmax),fspc0(iqqmax), & fspd0(iqqmax),fspb1(iqqmax),fspc1(iqqmax),fspd1(iqqmax), & fspb2(iqqmax),fspc2(iqqmax),fspd2(iqqmax),fspb3(iqqmax), & fspc3(iqqmax),fspd3(iqqmax)) Read(lwin,ERR=100,End=100) fdsx,fdsy,fdsy1,fdsy2,fdsy3,fspb0,fspc0,fspd0 & ,fspb1,fspc1,fspd1,fspb2,fspc2,fspd2,fspb3,fspc3,fspd3 End If Do iw=lout,lfile Write(iw,*) Write(iw,*) ' Reading from wel_file: ',welfile Write(iw,*) End Do Close(lwin) Return ! 100 Continue !--------------------------------------------------------------------- ! missing or corrupt 'welfile' file !--------------------------------------------------------------------- Close(lwin) Do iw=lout,lfile Write(iw,'(1x,a,a,a)') Write(iw,'(1x,a,a,a)') ' The file ',welfile,' is corrupted!' Write(iw,'(1x,a,i2,a)') ' Problem occurs at line ',counterLine,' ' Write(iw,'(1x,a,a,a)') ' STARTING FROM SCRATCH WITH ININ=IABS(ININ)!' Write(iw,'(1x,a,a,a)') End Do Call start Return End If !--------------------------------------------------------------------- ! write matrix elements to 'welfile' file !--------------------------------------------------------------------- If (is.Eq.2.And.iasswrong(3).Eq.0) Then !--------------------------------------------------------------------- ! Check status of file on disk !--------------------------------------------------------------------- file_exists=.False.; inquire(file=welfile, exist=file_exists); ierr=0 If(file_exists) Then file_opened=.False.; inquire(unit=lwou, opened=file_opened) If(file_opened) Then Close(lwou) Else End If Open(lwou,file=welfile,status='old',form='unformatted',IOSTAT=ierr) If(ierr.NE.0) Then Write(lout,'("Error in opening the old file, error code is ierr = ",i12)') ierr Return End If Else Open(lwou,file=welfile,status='new',form='unformatted',IOSTAT=ierr) If(ierr.NE.0) Then Write(lout,'("Error in opening the new file, error code is ierr = ",i12)') ierr Return End If End If !--------------------------------------------------------------------- ! Write data !--------------------------------------------------------------------- npr11=npr(1); npr1=npr(2) Write(lwou) npr11,npr1,ngh,ngl,n00,nb,nt Write(lwou) b0,bz,bp,beta0,si,etot,rms,bet,xmix,CpV0,CpV1,pwi, & del,ept,ala,ala2,alast,tz,varmas,varmasNZ,pjmassNZ, & ass,skass Write(lwou) ntx,nb,nhhdim Write(lwou) lambdaMax Write(lwou) multLag Write(lwou) id Write(lwou) brin ibasis=0 Do ib=1,NB ND=ID(ib) Do N1=1,ND ibasis=ibasis+1 NLA=NL(ibasis); NRA=NR(ibasis); NZA=NZ(ibasis); NSA=NS(ibasis); NLANSA1=(-1)**(NZA+NLA) Write(lwou) 2*NLA+NSA,NLANSA1,NZA+2*NRA+NLA,NZA,NLA End Do End Do !--------------------------------------------------------------------- ! blocking: sort blocking candidates first !--------------------------------------------------------------------- Do ib=1,2 Call blosort(ib,blomax(ib)) End Do Write(lwou) bloall Write(lwou) bloblo,blo123,blok1k2,blomax,bloqpdif !tel If(iLST.Gt.0) Then If(Allocated(fdsx)) Then Write(lwou) decay,rmm3,cmm3,amm3,bmm3,itass,iqqmax Write(lwou) fdsx,fdsy,fdsy1,fdsy2,fdsy3,fspb0,fspc0,fspd0 & ,fspb1,fspc1,fspd1,fspb2,fspc2,fspd2,fspb3,fspc3,fspd3 End If End If Close(lwou) Do iw=lout,lfile Write(iw,'(a,a,a)') Write(iw,'(a,a,a)') ' Writing to wel_file: ',welfile Write(iw,'(a,a,a)') ' __________________________________ ' Write(iw,'(a,a,a)') ' The tape ',welfile,' recorded: ' Write(iw,'(a,a,a)') ' nucname,npr,ngh,ngl,n00,nb,nt ' Write(iw,'(a,a,a)') ' b0,beta0,si,etot,rms,bet,xmix ' Write(iw,'(a,a,a)') ' pairing: CpV0,CpV1,pwi ' Write(iw,'(a,a,a)') ' delta: del,ept ' Write(iw,'(a,a,a)') ' lambda: ala,ala2,alast,tz ' Write(iw,'(a,a,a)') ' asymptotic: varmas,ass,skass ' Write(iw,'(a,a,a)') ' ntx,nb,nhhdim,id,N_rz,n_r,n_z ' Write(iw,'(a,a,a)') ' Omega2,Sigma2,Parity,Lambda ' Write(iw,'(a,a,a)') ' matrices(inbro): hh,de ' Write(iw,'(a,a,a)') ' *all blocking candidates ' If(Allocated(fdsx)) Write(iw,'(a,a,a)') ' *all THO arrays ' Write(iw,'(a,a,a)') ' __________________________________ ' Write(iw,'(a,a,a)') End Do End If ! End Subroutine inout !======================================================================= ! !======================================================================= Subroutine start !--------------------------------------------------------------------- ! initializes scratch Saxon-Woods potentials !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: iw,i,ih,il,ihl,it,ita Real(pr) :: zb(ngh),rrb(ngl),rb(ngl),rav,rao,vpws,vls,betas,gamma,fac, & facb,zz,rr,r,ctet,cphi,p2,p20,p22,s,u,w,f,rc,c,beta00, & b2_ws,b4_ws,pleg2,pleg4 !---------------------------------------------------------------------------- ! Re-initializing all again since scratch calculation !---------------------------------------------------------------------------- Call initialize_HFBTHO_SOLVER If(ierror_flag.Ne.0) Return Call Constraint_or_not(inin_INI,inin,icstr) If(ierror_flag.Ne.0) Return ! Setting restart to 1 for odd nuclei (blocking prescription) Do it=itmin,itmax If(npr(it).Ne.2*(npr(it)/2)) Then !irestart=irestart+1; npr(it)=npr_INI(it) ! Switch this off for HFODD End If End Do npr(3)=npr(1)+npr(2) If(irestart.Ne.0) Then ! odd nucleus requested but no even-even solution, recalculate the even-even nucleus from scratch Do iw=lout,lfile Write(iw,'(1x,a,2i4)') Write(iw,'(1x,a,2i4)') ' Initialization for the even-even core (N,Z)=: ',npr(1:2) End Do Else ! scratch for the even-even nucleus requested Do iw=lout,lfile Write(iw,'(1x,a,2i4)') Write(iw,'(a,a,3i4)') ' Scratch initialization for the nucleus: ',nucname,npr(1:2) Write(iw,'(1x,a,2i4)') End Do End If n00=Abs(n00_INI); b0=b0_INI; q=q_INI; iLST=iLST_INI maxi=MAX_ITER_INI; inin=inin_INI; skyrme=skyrme_INI; kindhfb=kindhfb_INI iproj=iproj_INI; npr1pj=npr1pj_INI; npr2pj=npr2pj_INI; icacou=0; icahartree=0 ! Call preparer(.False.) ! If(ierror_flag.Ne.0) Return inin=Abs(inin) ! positive even if inin_INI is not If(Abs(b2_0).Gt.1.5_pr) b2_0=1.5_pr ! Avoid crazy initial points (quadrupole deformation) If(Abs(b4_0).Gt.1.0_pr) b4_0=1.0_pr ! Avoid crazy initial points (hexadecapole deformation) !----------------------------------- ! Saxon-Woods potentials !----------------------------------- Do iw=lout,lfile Write(iw,'(/,a)') ' Initial potentials of Saxon-Woods shape ' End Do beta00=bet ! wf to requested deformation Do iw=lout,lfile Write(iw,'(a,2f14.8)') ' v0ws =',v0ws Write(iw,'(a,2f14.8)') ' kappa =',akv Write(iw,'(a,2f14.8)') ' vs0 =',vso Write(iw,'(a,2f14.8)') ' r0 =',r0v Write(iw,'(a,2f14.8)') ' a =',av Write(iw,'(a,2f14.8)') ' r0-so =',rso Write(iw,'(a,2f14.8)') ' a-so =',aso Write(iw,'(a,f14.8)') ' b2_ws =',b2_0 Write(iw,'(a,f14.8)') ' b4_ws =',b4_0 End Do !----------------------------------- ! Densities !----------------------------------- Do it=itmin,itmax ita=3-it; rav=r0v(it)*amas**p13; rao=rso(it)*amas**p13 vpws=v0ws*(one-akv*(npr(it)-npr(ita))/amas) vls=half*(hqc/amu)**2*vpws*vso(it) ! Deformations of the surface b2_ws = b2_0 * Sqrt(5.0_pr/(4.0_pr*pi)) b4_ws = b4_0 * Sqrt(9.0_pr/(4.0_pr*pi)) ! Volume conservation condition !gamma=zero !fac= one+betas*Cos( gamma*pi/180.0_pr) !fac=(one+betas*Cos((gamma+120.0_pr)*pi/180.0_pr))*fac !fac=(one+betas*Cos((gamma-120.0_pr)*pi/180.0_pr))*fac !fac=fac**(-p13) fac = two + (143.0_pr*Sqrt(five)*b2_ws**3 + 1287.0_pr*b2_ws**2*b4_ws + 390.0_pr*Sqrt(five)*b2_ws*b4_ws**2 & + 243.0_pr*b4_ws**3)/(2002.0_pr*Pi**1.5_pr) + (three*(b2_ws**2 + b4_ws**2))/(two*Pi) fac=(two/fac)**(p13) ! z,r-coordinates in fm zb=xh*bz; rrb=xl*bp*bp; rb=Sqrt(rrb) Do ih=1,ngh zz=zb(ih)**2 Do il=1,ngl rr=rrb(il)+zz; r=Sqrt(rr); ctet=zz/rr ! Deformed surface !p20=3.0_pr*ctet-one; p22=Sqrt(3.0_pr)*cphi !p2=p20*Cos(gamma*pi/180.0_pr)+p22*Sin(gamma*pi/180.0_pr) pleg2 = half*(three*ctet - one) pleg4 = (35.0_pr*ctet**2 - 30.0_pr*ctet + three)/eight facb=fac*(one + b2_ws*pleg2 + b4_ws*pleg4) ! Woods-Saxon potential u= vpws/( one+Exp( (r-rav*facb) / av(it) )) w=-vls /( one+Exp( (r-rao*facb) / aso(it))) ihl=ih+(il-1)*ngh If(it.Eq.1) Then vhbn(ihl)=hb0; vn(ihl)=u; vsn(ihl)=w; vrn(ihl)=zero; vzn(ihl)=zero; vdn(ihl)=zero; vSFIZn(ihl)=zero; vSZFIn(ihl)=zero; vSFIRn(ihl)=zero; vSRFIn(ihl)=zero; Else vhbp(ihl)=hb0; vp(ihl)=u; vsp(ihl)=w; vrp(ihl)=zero; vzp(ihl)=zero; vdp(ihl)=zero; vSFIZp(ihl)=zero; vSZFIp(ihl)=zero; vSFIRp(ihl)=zero; vSRFIp(ihl)=zero; End If ro(ihl,it)=u aka(ihl,it)=5.0d-3*Exp((r-rav*facb)/2.0_pr) End Do End Do s=npr(it)/Sum(ro(:,it)) Do il=1,ngl Do ih=1,ngh ihl=ih+(il-1)*ngh f=s/(pi*wh(ih)*wl(il)* bz*bp*bp); ro(ihl,it)=f*ro(ihl,it) End Do End Do !----------------------------------- ! pairing !----------------------------------- Do il=1,nghl If(it.Eq.1) Then dvn(il)=-100.0_pr*aka(il,it) Else dvp(il)=-100.0_pr*aka(il,it) End If End Do End Do !----------------------------------- ! coulomb !----------------------------------- If(icou.Eq.0) Then cou=zero Else rc=r0v(2)*amas**p13 Do il=1,ngl Do ih=1,ngh r=Sqrt(zb(ih)**2+rrb(il)) If (r.Lt.rc) Then c=half*(3/rc-r*r/(rc**3)) Else c=one/r End If cou(ih+(il-1)*ngh)=c*npr(2)/alphi End Do End Do End If !----------------------------------- ! initial ph+pp matrix elements !----------------------------------- ak=0.1_pr; rk=0.1_pr ! initial density matrix elements (improve later) brin=zero ! initial matrix elements to zero iiter=0 ! iteration number iiter to zero Call gamdel ! End Subroutine start !======================================================================= ! !======================================================================= Subroutine printRHO !--------------------------------------------------------------------- ! prints rho, aka !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr), Save :: ihli,Ifle Ifle=76+iLST1 If(Ifle.Eq.76) Open(Ifle,file='ho_den.dat',status='unknown') If(Ifle.Eq.77) Open(Ifle,file='tho_den.dat',status='unknown') Write(Ifle,*) 'r denN denP akaN akaP ' Do ihli=1,nghl Write(Ifle,'(12(1x,e16.8))') Sqrt(fh(ihli)**2+fl(ihli)**2) & ,ro(ihli,1),ro(ihli,2),aka(ihli,1),aka(ihli,2) End Do Close(Ifle) End Subroutine printRHO !======================================================================= ! !======================================================================= Subroutine gfv !--------------------------------------------------------------------- ! Calculates sign, Sqrt, factorials, etc. of integers and half int. ! iv(n)=(-1)**n, sq(n)=Sqrt(n), sqi(n)=1/Sqrt(n) ! fak(n)=n!; wf(n)=Sqrt(n!); wfi(n)=1/Sqrt(n!) !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: i,igfv Parameter(igfv=170) !maximal number for GFV If(Allocated(iv)) Deallocate(iv,fak,fi,sq,sqi,wf,wfi) Allocate(iv(-igfv:igfv),fak(0:igfv),fi(0:igfv),sq(0:igfv),sqi(0:igfv)) Allocate(wf(0:igfv),wfi(0:igfv)) iv(0)=1; sq(0)=zero; sqi(0)=1.0d30 fak(0)=one; fi(0)=one; wf(0)=one; wfi(0)=one Do i=1,igfv iv(i)=-iv(i-1) iv(-i) = iv(i) sq(i)=Sqrt(Real(i,Kind=pr)); sqi(i)=one/sq(i) fak(i)=Real(i,Kind=pr)*fak(i-1); fi(i)=one/fak(i) wf(i)=sq(i)*wf(i-1); wfi(i)=one/wf(i) End Do End Subroutine gfv !======================================================================= ! !======================================================================= Subroutine sdiag(nmax,n,a,d,x,e,is) !--------------------------------------------------------------------- ! A matrix to be diagonalized ! D eigenvalues, X eigenvectors, E auxiliary field ! IS=1 eigenvalues are ordered (major component of X is positive) ! 0 eigenvalues are not ordered !--------------------------------------------------------------------- Use HFBTHO_utilities, Only: pr,ipr Implicit None Integer(ipr), Save :: i,j,j1,k,l,im Integer(ipr) :: n,nmax,is Real(pr), Save :: f,g,h,hi,s,p,b,r,pra,c Real(pr) :: a(nmax,nmax),x(nmax,nmax),e(n),d(n) Real(pr), Save :: tol=1.0D-32,eps=9.0D-12,one=1.0_pr,zero=0.0_pr ! If (n.Le.1) Then d(1)=a(1,1); x(1,1)=one Return End If Do i=1,n Do j=1,i x(i,j)=a(i,j) End Do End Do ! householder-reduktion i=n 15 Continue If (i.Ge.2) Then l=i-2 f=x(i,i-1); g=f; h=zero If (l.Gt.0) Then Do k=1,l h=h+x(i,k)*x(i,k) End Do End If s=h+f*f If (s.Lt.tol) Then h=zero Go To 100 End If If (h.Gt.zero) Then l=l+1; g=Sqrt(s) If (f.Ge.zero) g=-g h=s-f*g; hi=one/h; x(i,i-1)=f-g; f=zero If (l.Gt.0) Then Do j=1,l x(j,i)=x(i,j)*hi s=zero Do k=1,j s=s+x(j,k)*x(i,k) End Do j1=j+1 If (l.Ge.j1) Then Do k=j1,l s=s+x(k,j)*x(i,k) End Do End If e(j)=s*hi; f=f+s*x(j,i) End Do End If f=f*hi*0.50_pr If (l.Gt.0) Then Do j=1,l s=x(i,j); e(j)=e(j)-f*s; p=e(j) Do k=1,j x(j,k)=x(j,k)-s*e(k)-x(i,k)*p End Do End Do End If End If 100 Continue d(i)=h; e(i-1)=g; i=i-1 Go To 15 ! Bereitstellen der Transformationmatrix End If d(1)=zero; e(n)=zero; b=zero; f=zero Do i=1,n l=i-1 If (d(i).Eq.0.) Go To 221 If (l.Gt.0) Then Do J=1,L s=zero Do k=1,l s=s+x(i,k)*x(k,j) End Do Do k=1,l x(k,j)=x(k,j)-s*x(k,i) End Do End Do End If 221 Continue d(i)=x(i,i) x(i,i)=one If (l.Gt.0) Then Do j=1,l x(i,j)=zero; x(j,i)=zero End Do End If End Do ! Diagonalisieren der Tri-Diagonal-Matrix Do l=1,n h=eps*(Abs(d(l))+ Abs(e(l))) If (h.Gt.b) b=h ! Test fuer Splitting Do j=l,n If (Abs(e(j)).Le.b) Exit End Do ! test fuer konvergenz If (j.Eq.l) Go To 300 340 p=(d(l+1)-d(l))/(2.0_pr*e(l)) r=Sqrt(p*p+one); pra=p+r If (p.Lt.zero) pra=p-r h=d(l)-e(l)/pra Do i=l,n d(i)=d(i)-h End Do f=f+h ! QR-transformation p=d(j); c=one; s=zero; i=j 360 i=i-1 If (i.Lt.l) Go To 362 g=c*e(i); h=c*p If ( Abs(p).Ge.Abs(e(i))) Then c=e(i)/p r=Sqrt(c*c+one); e(i+1)=s*p*r; s=c/r; c=one/r Go To 365 End If c=p/e(i) r=Sqrt(c*c+one); e(i+1)=s*e(i)*r; s=one/r; c=c/r 365 p=c*d(i)-s*g d(i+1)=h+s*(c*g+s*d(i)) Do k=1,n h=x(k,i+1); x(k,i+1)=x(k,i)*s+h*c x(k,i)=x(k,i)*c-h*s End Do Go To 360 362 e(l)=s*p d(l)=c*p If ( Abs(e(l)).Gt.b) Go To 340 ! konvergenz 300 d(l)=d(l)+f End Do If (is.Eq.0) Return ! ordnen der eigenwerte Do i=1,n k=i; p=d(i); j1=i+1 If (j1.Le.n) Then Do j=j1,n If (d(j).Ge.p) Cycle k=j; p=d(j) End Do If (k.Eq.i) Cycle d(k)=d(i); d(i)=p Do j=1,n p=x(j,i); x(j,i)=x(j,k) x(j,k)=p End Do End If End Do ! signum Do k=1,n s=zero Do i=1,n h=Abs(x(i,k)) If (h.Gt.s) Then s=h; im=i End If End Do If (x(im,k).Lt.zero) Then Do i=1,n x(i,k)=-x(i,k) End Do End If End Do End Subroutine sdiag !======================================================================= ! !======================================================================= Subroutine nucleus(is,npr2,te) !--------------------------------------------------------------------- ! is=1 determines the symbol for a given proton number npr2 ! 2 determines the proton number for a given symbol te !--------------------------------------------------------------------- Use HFBTHO_utilities, Only: pr,ipr Use HFBTHO, Only: ierror_flag,ierror_info Implicit None Integer(ipr) :: is,npr2,np Integer(ipr) :: maxz Parameter (maxz=133) Character(2) te Character(2*maxz+2) t T( 1: 40)=' n HHELIBE B C N O FNENAMGALSI P SCLAR K' T( 41: 80)='CASCTI VCRMNFECONICUZNGAGEASSEBRKRRBSR Y' T( 81:120)='ZRNBMOTCRORHPDAGCDINSNSBTE IXECSBALACEPR' T(121:160)='NDPMSMEUGDTBDYHOERTMYBLUHFTA WREOSIRPTAU' T(161:200)='HGTLPBBIPOATRNFRRAACTHPA UNPPUAMCMBKCFES' T(201:220)='FMMDNOLR040506070809' T(221:265)='101112131415161718192021222324252627282930313233' If (is.Eq.1) Then If (npr2.Lt.0.Or.npr2.Gt.maxz) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: in nucleus npr2 is wrong:' Return End If te=t(2*npr2+1:2*npr2+2) Return Else Do np=0,maxz If (te.Eq.t(2*np+1:2*np+2)) Then npr2=np Return End If End Do End If ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: in nucleus the nucleus is unknown!' End Subroutine nucleus !======================================================================= ! !======================================================================= Subroutine stab(npr2,npr3) !--------------------------------------------------------------------- ! given 'Z' returns mass number 'A' on the stability line !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: npr2,npr3 Real(pr), Save :: sn,sz,dsn,c,c5 c=0.0060_pr; c5=5.0_pr*c/3.0_pr; sz=npr2; sn=npr2 Do While(Abs(dsn).Lt.1.0d-5) dsn=sz-sn+c*(sn+sz)**(5.0_pr/3.0_pr) dsn=dsn/(-1.0_pr+c5*(sn+sz)**(2.0_pr/3.0_pr)) sn=sn-dsn End Do npr3=Int(sn) End Subroutine stab !======================================================================= ! !======================================================================= Subroutine ord(n,e) !--------------------------------------------------------------------- ! orders a set of numbers according to their size !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: n,i,k,j Real(pr), Save :: p Real(pr) :: e(n) Do i=1,n k=i; p=e(i) If (i.Lt.n) Then Do j=i+1,n If (e(j).Lt.p) Then k=j; p=e(j) End If End Do If (k.Ne.i) Then e(k)=e(i); e(i)=p End If End If End Do End Subroutine ord !======================================================================= ! !======================================================================= Subroutine blosort(it,n) !--------------------------------------------------------------------- ! sorting blocking candidates ! Integer(ipr) :: iblocking,bloall; Parameter(bloall=200) ! Integer(ipr), Dimension(0:bloall,2) :: bloblo,blo123=0,blok1k2=0 ! Real(pr), Dimension(0:bloall,2) :: bloqpdif ! Integer(ipr), Dimension(3) :: keyblo ! Integer(ipr), Dimension(2) :: blocross,blomax,blo123d,blok1k2d,blocanon ! Write(lwou) bloblo,blo123,blok1k2,blomax,bloqpdif !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: it,ip,n,i,k,j Real(pr) :: p Do i=1,n k=i; p=bloqpdif(i,it) If (i.Lt.n) Then Do j=i+1,n If (bloqpdif(j,it).Lt.p) Then k=j; p=bloqpdif(j,it) End If End Do If (k.Ne.i) Then bloqpdif(k,it)=bloqpdif(i,it); bloqpdif(i,it)=p ip=bloblo(k,it); bloblo(k,it)=bloblo(i,it); bloblo(i,it)=ip ip=blo123(k,it); blo123(k,it)=blo123(i,it); blo123(i,it)=ip ip=blok1k2(k,it); blok1k2(k,it)=blok1k2(i,it); blok1k2(i,it)=ip End If End If End Do End Subroutine blosort !======================================================================= ! !======================================================================= Subroutine tracesln !--------------------------------------------------------------------- ! CALCULATING THE LIPKIN-NOGAMI SUMS IN CANONICAL BASIS !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: iw,it,ib,k1,k2,kkk,k Real(pr) :: AAV,SNtor,SDtor Real(pr) :: S_U1V1,S_U1V3,S_U2V2,S_U3V1,S_U4V4 Real(pr) :: U_ACTU,U_ACTU2,U_ACTU3,U_ACTU4 Real(pr) :: V_ACTU,V_ACTU2,V_ACTU3,V_ACTU4 ! etr=zero Do it=itmin,itmax S_U1V1=ZERO; S_U1V3=ZERO; S_U2V2=ZERO; S_U3V1=ZERO; S_U4V4=ZERO Do ib=1,nb k1=ka(ib,it)+1; k2=ka(ib,it)+kd(ib,it) If(k1.Le.k2) Then kkk=lcanon(ib-1,it) Do k=1,id(ib) kkk=kkk+1; aav=vk(kkk,it) ! v^2 U_ACTU=Sqrt(AAV); U_ACTU2=U_ACTU*U_ACTU U_ACTU3=U_ACTU2*U_ACTU; U_ACTU4=U_ACTU2*U_ACTU2 V_ACTU=Sqrt(ONE-AAV); V_ACTU2=V_ACTU*V_ACTU V_ACTU3=V_ACTU2*V_ACTU; V_ACTU4=V_ACTU2*V_ACTU2 S_U1V1=S_U1V1+U_ACTU * V_ACTU S_U1V3=S_U1V3+U_ACTU * V_ACTU3 S_U2V2=S_U2V2+U_ACTU2 * V_ACTU2 !Tr r (1-r) S_U3V1=S_U3V1+U_ACTU3 * V_ACTU S_U4V4=S_U4V4+U_ACTU4 * V_ACTU4 !Tr (1-r)^2 r^2 End Do End If End Do !ib SNtor=8.0_pr*(S_U3V1*S_U1V3-S_U4V4) SDtor=32.0_pr*(S_U2V2*S_U2V2-S_U4V4) Geff(it)=del(it)**2/ept(it) ala2(it)=-Geff(it)*(SNtor/SDtor) If(ala2(it).Ge.10.0_pr) ala2(it)=4.0_pr ! ala2 goes to hell etr(it)=-four*ala2(it)*S_U2V2 ! to total energy End Do !it etr(3)=etr(1)+etr(2) !to total energy Do iw=lout,lfile Write(iw,'(26x,a,2(1x,f7.3),a,3(1x,f9.3),a,2(1x,f7.3))') & ' f: ala2(n,p)=',ala2,' #eln(n,p,t)=',etr,' #del+ala2=',del+ala2 End Do End Subroutine tracesln !======================================================================= ! !======================================================================= Subroutine tracesln_qp !--------------------------------------------------------------------- ! CALCULATING THE LIPKIN-NOGAMI TRACES IN QP SPACE !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: iw,nd,ib,i1,i2,n2,ibitnb,it,i1n2nd,i2n2nd,i1i2nd Real(pr) :: frit,frit2,ftit Real(pr) :: etr2(2),trk(2),trk1(2),SNtor(2),SDtor(2),Sum(2) ! ! initialization etr=zero; etr2=zero; trk=zero; trk1=zero ! loop over the blocks Do ib=1,nb nd=id(ib) ! Traces for neutrons and protons Do i2=1,nd ! index alpha Do i1=i2,nd ! index beta.ge.alpha sum=zero Do n2=1,nd i1n2nd=Max(i1,n2)+(Min(i1,n2)-1)*nd i2n2nd=Max(i2,n2)+(Min(i2,n2)-1)*nd Do it=itmin,itmax ibitnb=ib+(it-1)*nbx Sum(it)=Sum(it)+rk(i1n2nd,ibitnb)*rk(i2n2nd,ibitnb)*p14 End Do !it End Do !n2 i1i2nd=i1+(i2-1)*nd Do it=itmin,itmax ibitnb=ib+(it-1)*nbx frit=rk(i1i2nd,ibitnb)*half ftit=ak(i1i2nd,ibitnb) frit2=Sum(it) If(i1.Eq.i2) Then etr(it)=etr(it)+frit-frit**2 ! Tr r (1-r) etr2(it)=etr2(it)+(one-two*frit+frit2)*frit2 ! Tr (1-r)^2 r^2 trk(it)=trk(it)+frit*ftit ! Tr r k trk1(it)=trk1(it)+ftit -frit*ftit ! Tr k (1-r) Else etr(it)=etr(it) -two*frit**2 ! Tr r (1-r) etr2(it)=etr2(it)+two*(-two*frit+frit2)*frit2 ! Tr (1-r)^2 r^2 trk(it)=trk(it)+two*frit*ftit ! Tr r k trk1(it)=trk1(it)-two*ftit*frit ! Tr k (1-r) End If End Do !it End Do !i1 End Do !i2 End Do !ib ! total traces Do it=itmin,itmax SNtor(it)=8.0_pr*(trk1(it)*trk(it)-etr2(it)) SDtor(it)=32.0_pr*(etr(it)**2 -etr2(it)) Geff(it)=del(it)**2/ept(it) ala2(it)=-( SNtor(it)/SDtor(it) )*Geff(it) If(ala2(it).Ge.10.0_pr) ala2(it)=4.0_pr ! in case ala2 goes to hell etr(it)=-four*ala2(it)*etr(it) ! to total energy End Do etr(3)=etr(1)+etr(2) !to total energy Do iw=lout,lfile Write(iw,'(26x,a,2(1x,f7.3),a,3(1x,f9.3),a,2(1x,f7.3))') & ' #LN: ala2(n,p)=',ala2,' #eln(n,p,t)=',etr,' #del+ala2=',del+ala2 End Do End Subroutine tracesln_qp !======================================================================= ! !======================================================================= Subroutine densitln !--------------------------------------------------------------------- ! calculates the densities in r-space at gauss-meshpoints ! corrected due to Lipkin-Nogami !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: ih,il,ib,nd,i0,i01,i02,n1,n2,nza,nzb,nra,nrb,nla, & nlb,nsa,nsb,it,ml,ihli,k,k0(2),k00(2),k1,k2 Real(pr) :: fr(2),vvs,vvc,ssln1,ssln2,ssln3,vks Real(pr) :: qla,qlb,qlab,qha,qhb,qhlab,qhab,sro ! k0=0; k00=0 ro=zero ! loop over the blocks Do ib=1,nb k00=k0 nd=id(ib); i0=ia(ib) Do n2=1,nd i02=i0+n2; nzb=nz(i02); nrb=nr(i02); nlb=nl(i02); nsb=ns(i02) Do n1=1,n2 i01=i0+n1; nza=nz(i01); nra=nr(i01) nla=nl(i01); nsa=ns(i01) k0=k00 Do it=itmin,itmax k1=ka(ib,it)+1 k2=ka(ib,it)+kd(ib,it) fr(it)=zero If(k1.Le.k2) Then Do k=1,nd k0(it)=k0(it)+1 ssln1=ssln(1,it) ssln2=ssln(2,it) ssln3=ssln(3,it) vks=vk(k0(it),it) vvc=vks vvs=Abs(one-vks) If(vvs.Ge.1.0d-40) Then vvs=two*Sqrt(vks*vvs) !2vu vvc=vks+vvs**2*p14*ssln1*((two*vks-one)*ssln1-ssln2)/ssln3 End If fr(it)=fr(it)+two*ddc(n2,k0(it),it)*ddc(n1,k0(it),it)*vvc End Do If (n1.Ne.n2) Then fr(it)=two*fr(it) End If End If End Do !---diagonal in spin If (nsa.Eq.nsb) Then ml=nla Do il=1,ngl qla=ql (nra,ml,il); qlb=ql (nrb,ml,il) qlab=qla*qlb Do ih=1,ngh ihli=ih+(il-1)*ngh qha=qh (nza,ih); qhb=qh (nzb,ih) qhab=qha*qhb qhlab=qhab*qlab; sro=qhlab ro(ihli,:)=ro(ihli,:)+fr(:)*sro End Do !ih End Do !il End If End Do !n2 End Do !n1 End Do !ib ! set the THO weights Do ihli=1,nghl ro(ihli,:)=ro(ihli,:)*wdcori(ihli) End Do End Subroutine densitln !======================================================================= ! !======================================================================= Subroutine coulom1 !--------------------------------------------------------------------- ! Coulomb field (direct part) Vautherin prescription ! Ref.: Phys. Rev. C 7, 296 (1973) !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Use EllipticIntegral Implicit None Integer(ipr), Save :: i,k Real(pr) :: zd2,rhl,y1,y2,xx1,xx2,s1,s2,e1,e2,vik,f,r,r1,r4, & rr2,z,z1,zd1,x1,x2,fac1,fac2 ! If (IDEBUG.Eq.1) Call get_CPU_time('coulom1',0) ! If(icacou.Eq.0) Then ! icacou=1 ! ! For parity-breaking shapes, the Coulomb potential was incorrectly ! calculated by assuming the two intervals [0,+\infty[ and ]-infty,0] ! were equivalent (see also routine coulom() below). This bug was ! corrected in version 200d If(Parity) Then fac1 = one; fac2 = one Else fac1 = zero; fac2 = two End If ! f=half*chargee2/pi ! See notes in subroutine coulom for explanations about some numerical ! factors apparently missing here. !$OMP PARALLEL DO & !$OMP& DEFAULT(NONE) & !$OMP& SCHEDULE(DYNAMIC) & !$OMP& SHARED(nghl,fl,fh,fac1,fac2,wdcor,vc,f) & !$OMP& PRIVATE(i,r,z,r4,k,r1,z1,rr2,rhl,zd1,y1,xx1,s1,zd2,y2,xx2,s2,vik) Do i=1,nghl r=fl(i); z=fh(i) r4=four*r Do k=1,i r1=fl(k); z1=fh(k) rhl=r4*r1 ! 4 r r' rr2=(r+r1)**2 ! (r+r')^2 ! z>0 part zd1=(z-z1)**2 ! (z-z')^2 y1=zd1+rr2 ! d(r,z) = (r+r')^2 + (z-z')^2 xx1=rhl/y1 ! 4 r r' / d(r,z) s1=Sqrt(y1) ! sqrt(d(r,z)) ! z<0 part zd2=(z+z1)**2 y2=zd2+rr2 xx2=rhl/y2 s2=Sqrt(y2) ! vik = f*fac2*(s1*CompleteEllipticFunction_2nd(xx1) & +s2*CompleteEllipticFunction_2nd(xx2)*fac1) ! vc(i,k)=vik*wdcor(k) !wdcor=pi*wh*wl*bz*bp*bp vc(k,i)=vik*wdcor(i) !wdcor=pi*wh*wl*bz*bp*bp ! End Do !k End Do !i !$OMP End Parallel Do End If ! Calculation of the coulomb field (each iteration) cou=zero Call dgemm('n','n',nghl,1,nghl,1.0_pr,vc,nghl,dro(:,2),nghl,0.0_pr,cou,nghl) ! If (IDEBUG.Eq.1) Call get_CPU_time('coulom1',1) ! End Subroutine coulom1 !======================================================================= ! !======================================================================= Subroutine coulom !--------------------------------------------------------------------- ! Coulomb field (direct part), Gogny prescription ! Ref.: Phys. Rev. C 27, 2317 (1983) !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Use bessik Implicit None Integer(ipr), Save :: i,j,k Real(pr), Save :: zd2,y1,y2,xx1,s1,vik,f,r,r1,fac1,fac2,rr2,z,z1,zd1,t, & bb,r2,r12,rrr,rz1,rz2,rrz1,rrz2,xx,rk1,rip1,rkp1,alpha,& beta,xxx ! If (IDEBUG.Eq.1) Call get_CPU_time('coulom',0) ! If(icacou.Eq.0) Then ! icacou=1 ! ! For parity-breaking shapes, the Coulomb potential was incorrectly ! calculated by assuming the two intervals [0,+\infty[ and ]-infty,0] ! were equivalent (see also below). This bug was corrected in version ! 139a If(Parity) Then fac1 = one; fac2 = one Else fac1 = zero; fac2 = two End If ! Notes: ! - Missing factor 2 compared to Eq. (58) CPC paper because the density ! ro(:,it) already contains it (see routine DENSIT) due to T-invariance ! - Missing factor 1/2 when applying Gauss-Legendre quadrature (from [0,1] ! to the proper [-1,1] interval because it will be put back in subroutine ! expect() and is cancelled by a factor 2 in the HF field ! - For conserved parity, Gauss-Hermite points are all positive, the full ! integral over z' is split in z'<0 and z'>0, values of z and z1 below ! refer to the absolute values of z' (=-z' if z'<0) ! bb=50.0_pr ! Length scale L beta=2.00_pr alpha=one/beta f=chargee2/Sqrt(pi) ! e^2/Sqrt(pi) ! !$OMP PARALLEL DO & !$OMP& DEFAULT(NONE) & !$OMP& SCHEDULE(DYNAMIC) & !$OMP& SHARED(nghl,fl,fh,nleg,xleg,bb,fac1,fac2,wleg,wdcor,vc,f,alpha,beta) & !$OMP& PRIVATE(i,r,z,k,r1,z1,rrr,rr2,zd1,zd2,rz1,rz2,rrz1,rrz2, & !$OMP& xx1,j,xx,y1,s1,t,y2,vik,xxx) Do i=1,nghl r = fl(i); z = fh(i) Do k=1,i ! r1 = fl(k); z1 = fh(k) rrr = two*r*r1; rr2 = (r - r1)**2 ! z>0 part zd1 = (z - z1)**2 rz1 = rr2 + zd1 ! z<0 part zd2 = (z + z1)**2 rz2 = rr2 + zd2 ! Gauss-Legendre integration over u from 0 to D xx1=zero Do j=1,nleg xx=(one-xleg(j)**beta)**alpha ! change of variable to 0 <= u <= 1 xxx=(one-xleg(j)**beta)**(alpha+one) y1=(xleg(j)/(bb*xx))**2 ! u^2 s1=y1*rrr ! 2 u^2 r r' y2=besei0(s1) ! I0( 2 u^2 r r' ) * exp(-2 u^2 r r') xx1=xx1+fac2*wleg(j)*y2*(Exp(-rz1*y1) + fac1*Exp(-rz2*y1)) / xxx End Do vik=f*xx1/bb ! vc(i,k)=vik*wdcor(k) !wdcor=pi*wh*wl*bz*bp*bp vc(k,i)=vik*wdcor(i) !wdcor=pi*wh*wl*bz*bp*bp ! End Do !k End Do !i !$OMP End Parallel Do ! End If ! Calculation of the Coulomb field cou=zero Call dgemm('n','n',nghl,1,nghl,1.0_pr,vc,nghl,ro(:,2),nghl,0.0_pr,cou,nghl) ! If (IDEBUG.Eq.1) Call get_CPU_time('coulom',1) ! End Subroutine coulom !======================================================================= ! !======================================================================= Subroutine coulom_test !--------------------------------------------------------------------- ! Coulomb field (direct part), Gogny prescription ! Ref.: Phys. Rev. C 27, 2317 (1983) !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Use bessik Implicit None Integer(ipr), Save :: i,j,k Real(pr), Save :: zd2,y1,y2,xx1,s1,vik,f,r,r1,fac1,fac2,rr2,z,z1,zd1,t, & bb,r2,r12,rrr,rz1,rz2,rrz1,rrz2,xx,rk1,rip1,rkp1,alpha,& beta,xxx,func ! If (IDEBUG.Eq.1) Call get_CPU_time('coulom_test',0) ! ! ! For parity-breaking shapes, the Coulomb potential was incorrectly ! calculated by assuming the two intervals [0,+\infty[ and ]-infty,0] ! were equivalent (see also below). This bug was corrected in version ! 139a If(Parity) Then fac1 = one; fac2 = one Else fac1 = zero; fac2 = two End If ! bb=5.0_pr ! Length scale L beta=2.00_pr alpha=one/beta !f=chargee2/Sqrt(pi) ! e^2/Sqrt(pi) f=one/Sqrt(pi) ! 1/Sqrt(pi) ! Do j=1,nleg ! Gauss-Legendre integration over u from 0 to D xx=(one-xleg(j)**beta)**alpha ! change of variable to 0 <= u <= 1 xxx=(one-xleg(j)**beta)**(alpha+one) ! func=zero Do i=1,nghl r = fl(i); z = fh(i) Do k=1,i ! r1 = fl(k); z1 = fh(k) rrr = two*r*r1; rr2 = (r - r1)**2 ! z>0 part zd1 = (z - z1)**2 rz1 = rr2 + zd1 ! z<0 part zd2 = (z + z1)**2 rz2 = rr2 + zd2 y1=(xleg(j)/(bb*xx))**2 ! u^2 s1=y1*rrr ! 2 u^2 r r' y2=besei0(s1) ! I0( 2 u^2 r r' ) * exp(-2 u^2 r r') xx1=fac2*wleg(j)*y2*(Exp(-rz1*y1) + fac1*Exp(-rz2*y1)) / xxx vik=f*xx1/bb ! func=func+vik*wdcor(k)*ro(k,2)*wdcor(i)*ro(i,2) !wdcor=pi*wh*wl*bz*bp*bp ! End Do ! k End Do ! i Write(6,'(2f30.14)') xleg(j),func ! End Do !j ! If (IDEBUG.Eq.1) Call get_CPU_time('coulom_test',1) ! End Subroutine coulom_test !======================================================================= ! !======================================================================= Subroutine HartreeDir !--------------------------------------------------------------------- ! Hartree-field (direct part) !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: i,j,k Real(pr) :: xx1,vik00,vik01,vik11 Real(pr) :: r,rr,rrr,r1,r2,rr1,rr2 Real(pr) :: z,z1,zdm,zdp,rzm,rzp Real(pr), Allocatable :: u(:) If(icahartree.Eq.0) Then icahartree=1 ! If(Allocated(u)) Deallocate(u); Allocate(u(nleg)) u=Cos(HALF*Pi*xleg) Do i=1,nghl r=fl(i); z=fh(i); rr=r*r Do k=1,i r1=fl(k); z1=fh(k); rr1=r1*r1; rr2=two*r*r1; rrr=rr+rr1; zdm=(z-z1)**2; zdp=(z+z1)**2; rzm=rrr+zdm; rzp=rrr+zdp vik00=0.250_pr*Sum(wleg*( & + HartreeV00(Sqrt(rzp-rr2*u)) & + HartreeV00(Sqrt(rzm-rr2*u)) & + HartreeV00(Sqrt(rzp+rr2*u)) & + HartreeV00(Sqrt(rzm+rr2*u)))) vik01=0.250_pr*Sum(wleg*( & + HartreeV01(Sqrt(rzp-rr2*u)) & + HartreeV01(Sqrt(rzm-rr2*u)) & + HartreeV01(Sqrt(rzp+rr2*u)) & + HartreeV01(Sqrt(rzm+rr2*u)))) vik11=0.250_pr*Sum(wleg*( & + HartreeV11(Sqrt(rzp-rr2*u)) & + HartreeV11(Sqrt(rzm-rr2*u)) & + HartreeV11(Sqrt(rzp+rr2*u)) & + HartreeV11(Sqrt(rzm+rr2*u)))) vhart00(i,k)=vik00*wdcor(k) ! wdcor=pi*wh*wl*bz*bp*bp/fd vhart00(k,i)=vik00*wdcor(i) vhart01(i,k)=vik01*wdcor(k) vhart01(k,i)=vik01*wdcor(i) vhart11(i,k)=vik11*wdcor(k) vhart11(k,i)=vik11*wdcor(i) End Do !k End Do !i Deallocate(u) End If ! calculation of the Hartree field vDHartree=0.0_pr Do i=1,nghl vDHartree(:,1)=vDHartree(:,1)+vhart00(:,i)*(ro(i,1)+ro(i,2))+vhart01(:,i)*(ro(i,1)-ro(i,2)) vDHartree(:,2)=vDHartree(:,2)+vhart11(:,i)*(ro(i,1)-ro(i,2))+vhart01(:,i)*(ro(i,1)+ro(i,2)) End Do End Subroutine HartreeDir !======================================================================= ! !======================================================================= Subroutine optHFBTHO !--------------------------------------------------------------------- ! optimization arrays ! NB FI2D_opt(JA,ihil) == Laplacian(r,z) HOwf ! FID2D-xlamy2*FID == Laplacian(r,z,phy) FID ! FIU2D-xlapy2*FIU == Laplacian(r,z,phy) FIU !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: i,ih,il,ib,ibx,nd,nza,nra,nla,nsa Integer(ipr) :: ihil,laplus,im,JA,N1,N2,ndnd,n12,n21 Real(pr) :: qla,v2,v4,yi,y,y2,qha,qhla,xmi,u,u2,un,up,xxx Real(pr) :: sml2,cnzaa,cnraa,a,b Real(pr) :: FITW1,FITW2,FITW3,FITW4 Real(pr) :: fi1r,fi1z,fi2d,QHL1A,QH1LA,vh,vdh,vsh,hbh Real(pr) :: SRFIh,SFIRh,SFIZh,SZFIh,SNABLARh,SNABLAZh Real(pr) :: xlam,xlam2,xlamy,xlamy2,xlap,xlap2,xlapy,xlapy2,XLAMPY Real(pr) :: bpi,bpi2,bzi,bzi2,xh2 ! bpi=one/bp; bpi2=bpi*bpi; bzi=one/bz; bzi2=bzi*bzi ! !----------------------------------------- ! Allocate the optimization arrays !----------------------------------------- If(Allocated(QHLA_opt)) Deallocate(QHLA_opt,FI1R_opt,FI1Z_opt,FI2D_opt,y_opt) Allocate(QHLA_opt(ntx,nghl),FI1R_opt(ntx,nghl),FI1Z_opt(ntx,nghl),FI2D_opt(ntx,nghl),y_opt(nghl)) !---------------------------------------------- ! START BLOCKS !---------------------------------------------- Do ib=1,NB ND=ID(ib); IM=ia(ib) If(Parity) Then LAPLUS=(ib+1)/2 !Yesp Else LAPLUS=ib !Nop End If XLAP=LAPLUS; XLAM=XLAP-ONE; xlap2=xlap*xlap; xlam2=xlam*xlam !---------------------------------------------- ! SUM OVER GAUSS INTEGRATION POINTS !---------------------------------------------- Do IL=1,ngl v2=half/xl(il); v4=v2*v2 Do IH=1,ngh ihil=ih+(il-1)*ngh; xh2=xh(ih)**2 If(iLST1.Eq.0) Then ! HO-basis yi=Sqrt(xl(il))*bp; y=one/yi; y2=y*y xlamy=xlam*y; xlamy2=xlam2*y2; xlapy=xlap*y; xlapy2=xlap2*y2; XLAMPY=XLAMY+XLAPY Else ! THO-basis y=fli(ihil); y2=y*y; xlamy=xlam*y; u=xh(ih); u2=u*u; xlamy2=xlam2*y2; xlapy=xlap*y; xlapy2=xlap2*y2; XLAMPY=XLAMY+XLAPY End If y_opt(ihil)=y !---------------------------------------------- ! SCAN OVER BASIS STATES !---------------------------------------------- Do N1=1,ND JA=N1+IM; NLA=NL(JA); NRA=NR(JA); NZA=NZ(JA); NSA=NS(JA) SML2=NLA*NLA; CNZAA=NZA+NZA+1; CNRAA=NRA+NRA+NLA+1 QHA=QH(NZA,IH); QLA=QL(NRA,NLA,IL); QHLA=QHA*QLA QHL1A=QHA*QL1(NRA,NLA,IL)*V2; QH1LA=QH1(NZA,IH)*QLA If(iLST1.Eq.0) Then ! HO-basis FI1R=(two*Sqrt(xl(il))*bpi)*QHL1A FI1Z=bzi*QH1LA FI2D=((xh2-CNZAA)*bzi2+four*(p14-CNRAA*V2+SML2*V4)*xl(il)*bpi2 )*QHLA Else ! THO-basis u=xh(ih); u2=u*u; FI1R=FP4(IHIL)*QHLA+FP5(IHIL)*QH1LA+FP6(IHIL)*QHL1A FI1Z=FP1(IHIL)*QHLA+FP2(IHIL)*QH1LA+FP3(IHIL)*QHL1A FI2D=(FS1(IHIL)*QH1LA*QH1LA+FS2(IHIL)*QHL1A*QHL1A & +FOUR*FS4(IHIL)*QH1LA*QHL1A & +TWO*(FS5(IHIL)*QH1LA+FS6(IHIL)*QHL1A)*QHLA & +((U2-CNZAA)*FS1(IHIL)+(p14-CNRAA*V2+SML2*V4)*FS2(IHIL) & +FS3(IHIL))*QHLA*QHLA-TWO*(FI1R*FI1R+FI1Z*FI1Z))/(TWO*QHLA) End If QHLA_opt(JA,ihil)=QHLA; FI2D_opt(JA,ihil)=FI2D; FI1R_opt(JA,ihil)=FI1R; FI1Z_opt(JA,ihil)=FI1Z End Do !N1 ! End Do !IH End Do !IL End Do !IB End Subroutine optHFBTHO !======================================================================= ! !========================================================================= Subroutine DENSIT !--------------------------------------------------------------------- ! local densities in coordinate space !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: iw,nsa,nza,nra,nla,k,i,nd,il,ih,ihil,laplus,ii Integer(ipr) :: imen,ib,im,it,J,JJ,JA,JN,k0,k1,k2,ibiblo Integer(ipr) :: bb,size,ndxmax Parameter(ndxmax=(n00max+2)*(n00max+2)/4) Real(pr) :: s,ss,sd,yi,y,y2,sml2,cnzaa,cnraa,u,u2,v2,v4 Real(pr) :: anik,pnik,qhla,qh1la,qhl1a,qla,qha,fi1r,fi1z,fi2d,fidd Real(pr) :: xlam,xlam2,xlamy,xlamy2,xlap,xlap2,xlapy,xlapy2,XLAMPY Real(pr) :: TFIU,TFID,TFIUR,TFIDR,TFIUZ,TFIDZ,TFIUD2,TFIDD2 Real(pr) :: TPFIU,TPFID,TPFIUR,TPFIDR,TPFIUZ,TPFIDZ,TPFIUD2,TPFIDD2 Real(pr) :: PIU,PIUZ,PIUR,PIUD2,PID,PIDZ,PIDR,PIDD2 Real(pr) :: TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TEMP7,TEMP8,TEMP9,TEMP10,TEMP11,TW_T,PW_T,WGT(nghl) Real(pr) :: Takaihil,Troihil,Tdjihil,Ttauihil,Tdroihil,TSRFIihil Real(pr) :: TSFIRihil,TSFIZihil,TSZFIihil,TNABLARIHIL,TNABLAZIHIL Real(pr), Pointer :: TAKA(:),TRO(:),TDJ(:),TTAU(:),TDRO(:) Real(pr), Pointer :: TSRFI(:),TSFIR(:),TSFIZ(:),TSZFI(:),TNABLAR(:),TNABLAZ(:) Real(pr) :: time1,time2,fk,f1k Real(pr), Pointer :: EqpPo(:),VqpPo(:),UqpPo(:) Integer(ipr), Pointer :: KpwiPo(:),KqpPo(:) Real(pr) :: OMPTAKA(nghl,2),OMPTRO(nghl,2),OMPTDJ(nghl,2),OMPTTAU(nghl,2) Real(pr) :: OMPTDRO(nghl,2),OMPTSRFI(nghl,2),OMPTSFIR(nghl,2),OMPTSFIZ(nghl,2),OMPTSZFI(nghl,2) Real(pr) :: OMPTSZIF(nghl,2),OMPTNABLAR(nghl,2),OMPTNABLAZ(nghl,2) ! Real(pr) :: OMPFIU(ndxmax),OMPFID(ndxmax),OMPFIUR(ndxmax),OMPFIDR(ndxmax),OMPFIUZ(ndxmax) Real(pr) :: OMPFIDZ(ndxmax),OMPFIUD2N(ndxmax),OMPFIDD2N(ndxmax) ! Real(pr) :: OMPPFIU(ndxmax),OMPPFID(ndxmax),OMPPFIUR(ndxmax),OMPPFIDR(ndxmax),OMPPFIUZ(ndxmax) Real(pr) :: OMPPFIDZ(ndxmax),OMPPFIUD2N(ndxmax),OMPPFIDD2N(ndxmax) ! Real(pr) :: OMPAN(ndxmax*ndxmax),OMPANK(ndxmax*ndxmax) Real(pr) :: f_T(ndxmax),f1_T(ndxmax) Real(pr) :: dnrm2 external dnrm2 ! If (IDEBUG.Eq.1) Call get_CPU_time('densit',0) ! !----------------------------------------------- ! ZERO N & P DENSITIES !----------------------------------------------- RO=ZERO; TAU=ZERO; DJ=ZERO; DRO=ZERO; AKA=ZERO; SZFI=ZERO; SFIZ=ZERO SRFI=ZERO; SFIR=ZERO; NABLAR=ZERO; NABLAZ=ZERO; VARMAS=ZERO ! OMPTAKA = ZERO; OMPTRO = ZERO; OMPTDJ = ZERO; OMPTTAU = ZERO OMPTDRO = ZERO; OMPTSRFI = ZERO; OMPTSFIR = ZERO; OMPTSFIZ = ZERO OMPTSZFI = ZERO; OMPTNABLAR = ZERO; OMPTNABLAZ = ZERO; ! Do bb=0,2*NB-1 it = bb/NB + 1 ib = Mod(bb,NB)+1 ! ! case of zero particle number, only flush densities If((npr_INI(1).Eq.0).And.(it.Eq.1)) Cycle If((npr_INI(2).Eq.0).And.(it.Eq.2)) Cycle !----------------------------------------------- ! SCAN OVER BLOCKS !----------------------------------------------- ND=ID(ib); IM=ia(ib) If(Parity) Then LAPLUS=(ib+1)/2 !Yesp Else LAPLUS=ib !Nop End If XLAP=LAPLUS; XLAM=XLAP-ONE; xlap2=xlap*xlap; xlam2=xlam*xlam ! ! blocking ibiblo=bloblo(keyblo(it),it) K0=0; If(ibiblo.Eq.ib) K0=blo123d(it) ! !---------------------------------------------- ! PAIRING WINDOW QP WAVE FUNCTIONS !---------------------------------------------- k1=ka(ib,it)+1; k2=ka(ib,it)+kd(ib,it); imen=k2-k1+1 If(IMEN.Gt.0) Then ompan=ZERO; ompank=ZERO; f_T=ZERO; f1_T=ZERO J=0 If(it.Eq.1) then Do JJ=1,nd ! basis Do K=K1,K2 ! qp J=J+1; I=KpwiN(K)+JJ; ompan(J)=RVqpN(I); ompank(J)=RUqpN(I) End Do End Do J=0 Do K=K1,K2 J=J+1;JJ=K !KpwiN(K) f_T(J)=one-fn_T(JJ);f1_T(J)=fn_T(JJ) End Do Else Do JJ=1,nd ! basis Do K=K1,K2 ! qp J=J+1; I=KpwiP(K)+JJ; ompan(J)=RVqpP(I); ompank(J)=RUqpP(I) End Do End Do J=0 Do K=K1,K2 J=J+1;JJ=K !KpwiP(K) f_T(J)=one-fp_T(JJ);f1_T(J)=fp_T(JJ) End Do End If !----------------------------------------------- ! SCAN OVER GAUSS INTEGRATION POINTS !----------------------------------------------- Do ihil=1,nghl y=y_opt(ihil); xlamy =xlam*y; xlapy =xlap*y; XLAMPY=XLAMY+XLAPY y2=y*y; xlamy2=xlam2*y2; xlapy2=xlap2*y2 Do K=1,IMEN ! V_k components OMPFIU(K) = ZERO; OMPFIUZ(K) = ZERO; OMPFIUR(K) = ZERO OMPFID(K) = ZERO; OMPFIDZ(K) = ZERO; OMPFIDR(K) = ZERO OMPFIUD2N(K) = ZERO; OMPFIDD2N(K) = ZERO; ! U_k components OMPPFIU(K) = ZERO; OMPPFIUZ(K) = ZERO; OMPPFIUR(K) = ZERO OMPPFID(K) = ZERO; OMPPFIDZ(K) = ZERO; OMPPFIDR(K) = ZERO OMPPFIUD2N(K) = ZERO; OMPPFIDD2N(K) = ZERO; End Do If(K0.Ne.0) Then PIU=ZERO; PIUZ=ZERO; PIUR=ZERO; PIUD2=ZERO PID=ZERO; PIDZ=ZERO; PIDR=ZERO; PIDD2=ZERO End If !----------------------------------------------- ! SUM OVER BASIS STATES !----------------------------------------------- JN=0 Do I=1,ND JA=IM+I; NSA=NS(JA); JN=(I-1)*imen QHLA=QHLA_opt(JA,ihil); FI2D=FI2D_opt(JA,ihil) FI1Z=FI1Z_opt(JA,ihil); FI1R=FI1R_opt(JA,ihil) !----------------------------------------------- ! QUASIPARTICLE WF IN COORDINATE SPACE !----------------------------------------------- If (NSA.Gt.0) Then ! SPIN Up Call DAXPY(IMEN,-QHLA,OMPANK(JN+1),1,OMPPFIU,1) ! temperature If(switch_on_temperature) Then Call DAXPY(IMEN,-FI2D,OMPANK(JN+1),1,OMPPFIUD2N,1) Call DAXPY(IMEN,-FI1R,OMPANK(JN+1),1,OMPPFIUR,1) Call DAXPY(IMEN,-FI1Z,OMPANK(JN+1),1,OMPPFIUZ,1) End If Call DAXPY(IMEN, QHLA,OMPAN(JN+1) ,1,OMPFIU,1) Call DAXPY(IMEN, FI2D,OMPAN(JN+1) ,1,OMPFIUD2N,1) Call DAXPY(IMEN, FI1R,OMPAN(JN+1) ,1,OMPFIUR,1) Call DAXPY(IMEN, FI1Z,OMPAN(JN+1) ,1,OMPFIUZ,1) ! blocking If(K0.Ne.0) Then PNIK = OMPANK(JN+K0) PIU = PIU + PNIK*QHLA PIUD2 = PIUD2 + PNIK*FI2D PIUR = PIUR + PNIK*FI1R PIUZ = PIUZ + PNIK*FI1Z End If Else ! SPIN Down Call DAXPY(IMEN,-QHLA,OMPANK(JN+1),1,OMPPFID,1) ! temperature If(switch_on_temperature) Then Call DAXPY(IMEN,-FI2D,OMPANK(JN+1),1,OMPPFIDD2N,1) Call DAXPY(IMEN,-FI1R,OMPANK(JN+1),1,OMPPFIDR,1) Call DAXPY(IMEN,-FI1Z,OMPANK(JN+1),1,OMPPFIDZ,1) End If Call DAXPY(IMEN, QHLA,OMPAN(JN+1) ,1,OMPFID,1) Call DAXPY(IMEN, FI2D,OMPAN(JN+1) ,1,OMPFIDD2N,1) Call DAXPY(IMEN, FI1R,OMPAN(JN+1) ,1,OMPFIDR,1) Call DAXPY(IMEN, FI1Z,OMPAN(JN+1) ,1,OMPFIDZ,1) ! blocking If(K0.Ne.0) Then PNIK = OMPANK(JN+K0) PID = PID + PNIK*QHLA PIDD2 = PIDD2 + PNIK*FI2D PIDR = PIDR + PNIK*FI1R PIDZ = PIDZ + PNIK*FI1Z End If End If End Do ! I=1,ND !----------------------------------------------- ! DENSITIES IN COORDINATE SPACE !----------------------------------------------- Takaihil=zero; Troihil=zero; Tdjihil=zero; Ttauihil=zero; Tdroihil=zero TSRFIihil=zero; TSFIRihil=zero; TSFIZihil=zero; TSZFIihil=zero; TNABLARIHIL=zero; TNABLAZIHIL=zero ! Do K=1,IMEN TFIU=OMPFIU(K); TFIUZ=OMPFIUZ(K); TFIUR=OMPFIUR(K); TFIUD2=OMPFIUD2N(K); TPFIU=OMPPFIU(K) TFID=OMPFID(K); TFIDZ=OMPFIDZ(K); TFIDR=OMPFIDR(K); TFIDD2=OMPFIDD2N(K); TPFID=OMPPFID(K) ! If(switch_on_temperature) Then ! fk=f_T(K); f1k=f1_T(K) ! TPFIUZ=OMPPFIUZ(K); TPFIUR=OMPPFIUR(K); TPFIUD2=OMPPFIUD2N(K) TPFIDZ=OMPPFIDZ(K); TPFIDR=OMPPFIDR(K); TPFIDD2=OMPPFIDD2N(K) ! TEMP1 = (TPFIU*TFIU+TPFID*TFID)*fk-(TFIU*TPFIU+TFID*TPFID)*f1k TAKAIHIL = TAKAIHIL + TEMP1 TEMP2 = (TFIU*TFIU+TFID*TFID)*fk+(TPFIU*TPFIU+TPFID*TPFID)*f1k TROIHIL = TROIHIL + TEMP2 TEMP3 = (TFIUR *TFIDZ -TFIDR *TFIUZ +XLAMY*TFIU *(TFIUR -TFIDZ) -XLAPY*TFID *(TFIDR +TFIUZ)) *fk & + (TPFIUR*TPFIDZ-TPFIDR*TPFIUZ+XLAMY*TPFIU*(TPFIUR-TPFIDZ)-XLAPY*TPFID*(TPFIDR+TPFIUZ))*f1k TDJIHIL = TDJIHIL + TEMP3 ! TW_T=(TFIUR *TFIUR +TFIDR *TFIDR +TFIUZ *TFIUZ +TFIDZ *TFIDZ)*fk& +(TPFIUR*TPFIUR+TPFIDR*TPFIDR+TPFIUZ*TPFIUZ+TPFIDZ*TPFIDZ)*f1k ! TEMP4 = (XLAMY2*TFIU *TFIU +XLAPY2*TFID *TFID) *fk & + (XLAMY2*TPFIU*TPFIU+XLAPY2*TPFID*TPFID)*f1k + TW_T TTAUIHIL = TTAUIHIL + TEMP4 TEMP5 = (TFIU*TFIUD2+TFID*TFIDD2)*fk + (TPFIU*TPFIUD2+TPFID*TPFIDD2)*f1k + TW_T TDROIHIL = TDROIHIL + TEMP5 TEMP6 = (TFIUR*TFID-TFIDR*TFIU)*fk + (TPFIUR*TPFID-TPFIDR*TPFIU)*f1k TSRFIIHIL = TSRFIIHIL + TEMP6 TEMP7 = (TFIU*TFID*XLAMPY)*fk + (TPFIU*TPFID*XLAMPY)*f1k TSFIRIHIL = TSFIRIHIL + TEMP7 TEMP8 = (XLAMY*TFIU*TFIU-XLAPY*TFID*TFID)*fk + (XLAMY*TPFIU*TPFIU-XLAPY*TPFID*TPFID)*f1k TSFIZIHIL = TSFIZIHIL + TEMP8 TEMP9 = (TFIUZ*TFID-TFIDZ*TFIU)*fk + (TPFIUZ*TPFID-TPFIDZ*TPFIU)*f1k TSZFIIHIL = TSZFIIHIL + TEMP9 TEMP10 = (TFIUR*TFIU+TFIDR*TFID)*fk + (TPFIUR*TPFIU+TPFIDR*TPFID)*f1k TNABLARIHIL = TNABLARIHIL + TEMP10 TEMP11 = (TFIUZ*TFIU+TFIDZ*TFID)*fk + (TPFIUZ*TPFIU+TPFIDZ*TPFID)*f1k TNABLAZIHIL = TNABLAZIHIL + TEMP11 ! Else ! TEMP1 = TPFIU*TFIU+TPFID*TFID; TAKAIHIL = TAKAIHIL + TEMP1 TEMP2 = TFIU*TFIU+TFID*TFID; TROIHIL = TROIHIL + TEMP2 TEMP3 = TFIUR*TFIDZ-TFIDR*TFIUZ & +XLAMY*TFIU*(TFIUR-TFIDZ) & -XLAPY*TFID*(TFIDR+TFIUZ) ; TDJIHIL = TDJIHIL + TEMP3 ! TW_T=TFIUR*TFIUR+TFIDR*TFIDR+TFIUZ*TFIUZ+TFIDZ*TFIDZ ! TEMP4 = XLAMY2*TFIU*TFIU+XLAPY2*TFID*TFID+TW_T; TTAUIHIL = TTAUIHIL + TEMP4 TEMP5 = TFIU*TFIUD2+TFID*TFIDD2 +TW_T; TDROIHIL = TDROIHIL + TEMP5 TEMP6 = TFIUR*TFID-TFIDR*TFIU; TSRFIIHIL = TSRFIIHIL + TEMP6 TEMP7 = TFIU*TFID*XLAMPY; TSFIRIHIL = TSFIRIHIL + TEMP7 TEMP8 = XLAMY*TFIU*TFIU-XLAPY*TFID*TFID; TSFIZIHIL = TSFIZIHIL + TEMP8 TEMP9 = TFIUZ*TFID-TFIDZ*TFIU; TSZFIIHIL = TSZFIIHIL + TEMP9 TEMP10 = TFIUR*TFIU+TFIDR*TFID; TNABLARIHIL = TNABLARIHIL+ TEMP10 TEMP11 = TFIUZ*TFIU+TFIDZ*TFID; TNABLAZIHIL = TNABLAZIHIL+ TEMP11 ! End If ! If(K.Ne.K0) Cycle ! ! blocking TAKAIHIL = TAKAIHIL - TEMP1; TEMP1 = PIU*PIU+PID*PID TROIHIL = TROIHIL - HALF*(TEMP2 - TEMP1); TEMP2 = PIUR*PIDZ-PIDR*PIUZ+XLAMY*PIU*(PIUR-PIDZ) & -XLAPY*PID*(PIDR+PIUZ) ! PW_T=PIUR*PIUR+PIDR*PIDR+PIUZ*PIUZ+PIDZ*PIDZ TDJIHIL = TDJIHIL - HALF*(TEMP3 - TEMP2); TEMP3 = PW_T+XLAMY2*PIU*PIU+XLAPY2*PID*PID TTAUIHIL = TTAUIHIL - HALF*(TEMP4 - TEMP3); TEMP4 = PW_T+PIU*PIUD2+PID*PIDD2; TDROIHIL = TDROIHIL - HALF*(TEMP5 - TEMP4); TEMP5 = PIUR*PID-PIDR*PIU; TSRFIIHIL = TSRFIIHIL - HALF*(TEMP6 - TEMP5); TEMP6 = PIU*PID*XLAMPY; TSFIRIHIL = TSFIRIHIL - HALF*(TEMP7 - TEMP6); TEMP7 = XLAMY*PIU*PIU-XLAPY*PID*PID; TSFIZIHIL = TSFIZIHIL - HALF*(TEMP8 - TEMP7); TEMP8 = PIUZ*PID-PIDZ*PIU; TSZFIIHIL = TSZFIIHIL - HALF*(TEMP9 - TEMP8); TEMP9 = PIUR*PIU+PIDR*PID; TNABLARIHIL = TNABLARIHIL - HALF*(TEMP10- TEMP9); TEMP10 = PIUZ*PIU+PIDZ*PID; TNABLAZIHIL = TNABLAZIHIL - HALF*(TEMP11- TEMP10) End Do !K OMPTaka(ihil,it) = OMPTaka(ihil,it) + TAKAIHIL OMPTro(ihil,it) = OMPTro(ihil,it) + TROIHIL OMPTdj(ihil,it) = OMPTdj(ihil,it) + TDJIHIL OMPTtau(ihil,it) = OMPTtau(ihil,it) + TTAUIHIL OMPTdro(ihil,it) = OMPTdro(ihil,it) + TDROIHIL OMPTSRFI(ihil,it) = OMPTSRFI(ihil,it) + TSRFIIHIL OMPTSFIR(ihil,it) = OMPTSFIR(ihil,it) + TSFIRIHIL OMPTSFIZ(ihil,it) = OMPTSFIZ(ihil,it) + TSFIZIHIL OMPTSZFI(ihil,it) = OMPTSZFI(ihil,it) + TSZFIIHIL OMPTNABLAR(IHIL,IT) = OMPTNABLAR(IHIL,IT) + TNABLARIHIL OMPTNABLAZ(IHIL,IT) = OMPTNABLAZ(IHIL,IT) + TNABLAZIHIL End Do !ihil End If End Do !bb Do it=1,2 Do ihil = 1,nghl AKA(ihil,it) = OMPTaka(ihil,it) RO(ihil,it) = OMPTro(ihil,it) DJ(ihil,it) = OMPTdj(ihil,it) TAU(ihil,it) = OMPTtau(ihil,it) DRO(ihil,it) = OMPTdro(ihil,it) SRFI(ihil,it) = OMPTSRFI(ihil,it) SFIR(ihil,it) = OMPTSFIR(ihil,it) SFIZ(ihil,it) = OMPTSFIZ(ihil,it) SZFI(ihil,it) = OMPTSZFI(ihil,it) NABLAR(ihil,it) = OMPTNABLAR(ihil,it) NABLAZ(ihil,it) = OMPTNABLAZ(ihil,it) End Do End Do Do it = 1,2 TRO=>ro(:,it); TTAU=>tau(:,it); TDJ=>dj(:,it); TDRO=>dro(:,it) TSZFI=>SZFI(:,it); TSFIZ=>SFIZ(:,it); TSRFI=>SRFI(:,it); TSFIR=>SFIR(:,it) TNABLAR=>NABLAR(:,it); TNABLAZ=>NABLAZ(:,it); TAKA=>aka(:,it) s=two*Sum(tro); sd=four*Sum(tdro); drhoi(it)=sd; Sumnz(it)=Abs(s-Real(npr(it),Kind=pr)) varmas=varmas+s; DNFactor(it)=Real(npr(it),Kind=pr)/s !---------------------------------------------------- ! REMOVES INT.WEIGHTS AND MULTIPLIES BY THE JACOBIAN !---------------------------------------------------- piu=two*Real(npr(it),Kind=pr)/s WGT=wdcori Call dscal(NGHL,piu,WGT,1) Tro=Tro*WGT; Ttau=Ttau*WGT; Taka=Half*Taka*WGT; TSRFI=TSRFI*WGT; TSFIR=TSFIR*WGT; TSFIZ=TSFIZ*WGT; TSZFI=TSZFI*WGT; Call dscal(NGHL,two,WGT,1) Tdro=Tdro*WGT; Tdj=Tdj*WGT TNABLAR=TNABLAR*WGT; TNABLAZ=TNABLAZ*WGT ! End Do !it DNFactor(3)=DNFactor(1)+DNFactor(2) ! If (IDEBUG.Eq.1) Call get_CPU_time('densit',1) !---------------------------------------------------- ! COULOMB AND HARTREE FIELDS !---------------------------------------------------- If(nleg.Lt.0) Then Call coulom1 Else Call coulom End If !Call HartreeDir End Subroutine DENSIT !======================================================================= ! !======================================================================= Subroutine field !--------------------------------------------------------------------- ! calculates fields in r-space form axially symmetric densities !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: iw,it,ita,ihli,lambda,icons Real(pr) :: ra,ra2,rs,rsa,rsa0,z,rrr Real(pr) :: rt,rt1,ds,da,dt,dt1,tts,tta,tt,tt1,djs,dja,djt,djt1 Real(pr) :: rsa0A,rsa0A1,V0V1,v01a,rns,rps,rsa1,rsa12,rsa10 Real(pr) :: rsa0An,rsa0An1,rsa0As,rsa0As1 Real(pr) :: RHO_0,RHO_1,TAU_0,TAU_1,DRHO_0,DRHO_1,DJ_0,DJ_1 Real(pr) :: SZFIN,SFIZN,SRFIN,SFIRN,SZFIP,SFIZP,SRFIP,SFIRP Real(pr) :: SZFI_0,SFIZ_0,SRFI_0,SFIR_0,SZFI_1,SFIZ_1,SRFI_1,SFIR_1 Real(pr) :: SNABLARN,SNABLAZN,SNABLARP,SNABLAZP Real(pr) :: SNABLAR_0,SNABLAZ_0,SNABLAR_1,SNABLAZ_1 Real(pr) :: J2_0,J2_1 Real(pr) :: cx,x Real(pr), Dimension(0:8) :: Qval Real(pr),Dimension(2) :: pUr,pUt,pUNr,pUNz,pUDr,pUDj,pUFIZ,pUZFI,pUFIR,pURFI Real(pr),Dimension(2) :: tUr,tUt,tUNr,tUNz,tUDr,tUDj,tUFIZ,tUZFI,tUFIR,tURFI Real(pr), Save :: ALAMBDA=0.0_pr,AEPSI=1.0_pr,CSPR=1.0_pr ! If (IDEBUG.Eq.1) Call get_CPU_time('field',0) ! ! fields Do ihli=1,nghl ! RHO_0 =ro(ihli,1)+ro(ihli,2) ; RHO_1 =ro(ihli,1)-ro(ihli,2) TAU_0 =tau(ihli,1)+tau(ihli,2) ; TAU_1 =tau(ihli,1)-tau(ihli,2) DRHO_0=dro(ihli,1)+dro(ihli,2) ; DRHO_1=dro(ihli,1)-dro(ihli,2) DJ_0 =dj(ihli,1)+dj(ihli,2) ; DJ_1 =dj(ihli,1)-dj(ihli,2) SFIZ_0=SFIZ(ihli,1)+SFIZ(ihli,2) ; SFIZ_1=SFIZ(ihli,1)-SFIZ(ihli,2) SFIR_0=SFIR(ihli,1)+SFIR(ihli,2) ; SFIR_1=SFIR(ihli,1)-SFIR(ihli,2) SZFI_0=SZFI(ihli,1)+SZFI(ihli,2) ; SZFI_1=SZFI(ihli,1)-SZFI(ihli,2) SRFI_0=SRFI(ihli,1)+SRFI(ihli,2) ; SRFI_1=SRFI(ihli,1)-SRFI(ihli,2) SNABLAR_0=NABLAR(ihli,1)+NABLAR(ihli,2) SNABLAR_1=NABLAR(ihli,1)-NABLAR(ihli,2) SNABLAZ_0=NABLAZ(ihli,1)+NABLAZ(ihli,2) SNABLAZ_1=NABLAZ(ihli,1)-NABLAZ(ihli,2) ! J2_0=SFIZ_0**2+SFIR_0**2+SZFI_0**2+SRFI_0**2 J2_1=SFIZ_1**2+SFIR_1**2+SZFI_1**2+SRFI_1**2 ! tUr=zero ; tUDr=zero ; tUNr=zero ; tUNz=zero tUt=zero ; tUDj=zero ; tUFIZ=zero ; tUZFI=zero tUFIR=zero ; tURFI=zero ; ! Call calculate_U_parameters(RHO_0,RHO_1,TAU_0,TAU_1,DRHO_0,DRHO_1, & (SNABLAR_0**2+SNABLAZ_0**2),(SNABLAR_1**2+SNABLAZ_1**2) ) ! ! FUNCTIONAL ! E=E+(hb0*(TAU_0+TAU_1)*HALF+hb0*(TAU_0-TAU_1)*HALF & ! tau !+Urhotau(0,0)*RHO_0*TAU_0+Urhotau(1,0)*RHO_1*TAU_1 & ! rho tau !+Urhotau(2,0)*RHO_0*TAU_1+Urhotau(3,0)*RHO_1*TAU_0 & !+Urhorho(0,0)*RHO_0**2+Urhorho(1,0)*RHO_1**2 & ! rho^2 !+(Urhorho(2,0)+Urhorho(3,0))*RHO_0*RHO_1 & !+UrhoDrho(0,0)*RHO_0*DRHO_0+UrhoDrho(1,0)*RHO_1*DRHO_1 & ! rho Delta rho !+UrhoDrho(2,0)*RHO_0*DRHO_1+UrhoDrho(3,0)*RHO_1*DRHO_0 & !+Unablarho(0,0)*(SNABLAR_0*SNABLAR_0+SNABLAZ_0*SNABLAZ_0) & ! (nabla rho)^2 !+Unablarho(1,0)*(SNABLAR_1*SNABLAR_1+SNABLAZ_1*SNABLAZ_1) & !+(Unablarho(3,0)+Unablarho(2,0))*(SNABLAR_0*SNABLAR_1+SNABLAZ_0*SNABLAZ_1) & !+UrhonablaJ(0,0)*RHO_0*DJ_0+UrhonablaJ(1,0)*RHO_1*DJ_1 & ! rho nabla J !+UrhonablaJ(2,0)*RHO_0*DJ_1+UrhonablaJ(3,0)*RHO_1*DJ_0 & !+UJnablarho(0,0)*(SNABLAR_0*(SFIZ_0-SZFI_0)-SNABLAZ_0*(SFIR_0-SRFI_0)) & ! J nabla rho !+UJnablarho(1,0)*(SNABLAR_1*(SFIZ_1-SZFI_1)-SNABLAZ_1*(SFIR_1-SRFI_1)) & !+UJnablarho(2,0)*(SNABLAR_1*(SFIZ_0-SZFI_0)-SNABLAZ_1*(SFIR_0-SRFI_0)) & !+UJnablarho(3,0)*(SNABLAR_0*(SFIZ_1-SZFI_1)-SNABLAZ_0*(SFIR_1-SRFI_1)) & !+UJJ(0,0)*J2_0+UJJ(1,0)*J2_1 & ! JJ !+(UJJ(3,0)+UJJ(2,0))*(SFIZ_0*SFIZ_1+SFIR_0*SFIR_1+SZFI_0*SZFI_1+SRFI_0*SRFI_1) ! ! tUr(1)=dE/d RHO_0; tUr(2)=dE/d RHO_1 ! tUt(1)=dE/d TAU_0; tUt(2)=dE/d TAU_1 ! tUDr(1)=dE/d DeltaRHO_0; tUDr(2)=dE/d DeltaRHO_1 ! and so on ... ! !TEST !Write(*,'(4(2x,g26.10))') UrhoDrho(0,0)-CrDr(0),CrDr(0),UrhoDrho(1,1)-CrDr(1),CrDr(1); pause ! Contributions in the case 'u' depends on RHO_0 tUr(1)=tUr(1)+two*Urhorho(0,0)*RHO_0+Urhorho(0,1)*RHO_0*RHO_0+Urhorho(1,1)*RHO_1*RHO_1 & !! rho^2 +(Urhorho(3,0)+Urhorho(2,0))*RHO_1+(Urhorho(3,1)+Urhorho(2,1))*RHO_0*RHO_1 tUr(2)=tUr(2)+two*Urhorho(1,0)*RHO_1+Urhorho(0,2)*RHO_0*RHO_0+Urhorho(1,2)*RHO_1*RHO_1 & +(Urhorho(3,0)+Urhorho(2,0))*RHO_0+(Urhorho(3,2)+Urhorho(2,2))*RHO_0*RHO_1 tUr(1)=tUr(1)+vDHartree(ihli,1) tUr(2)=tUr(2)+vDHartree(ihli,2) ! tUr(1)=tUr(1)+Urhotau(0,0)*TAU_0+Urhotau(0,1)*TAU_0*RHO_0+Urhotau(1,1)*TAU_1*RHO_1 & !! rho tau +Urhotau(2,0)*TAU_1+Urhotau(2,1)*RHO_0*TAU_1+Urhotau(3,1)*RHO_1*TAU_0 tUt(1)=tUt(1)+Urhotau(0,0)*RHO_0+Urhotau(3,0)*RHO_1 tUr(2)=tUr(2)+Urhotau(1,0)*TAU_1+Urhotau(1,2)*TAU_1*RHO_1+Urhotau(0,2)*TAU_0*RHO_0 & +Urhotau(3,0)*TAU_0+Urhotau(3,2)*RHO_1*TAU_0+Urhotau(2,2)*RHO_0*TAU_1 tUt(2)=tUt(2)+Urhotau(1,0)*RHO_1+Urhotau(2,0)*RHO_0 ! tUr(1)=tUr(1)+UrhoDrho(0,0)*DRHO_0+UrhoDrho(0,1)*RHO_0*DRHO_0+UrhoDrho(1,1)*RHO_1*DRHO_1 & !! rho Delta rho +UrhoDrho(2,0)*DRHO_1+UrhoDrho(2,1)*RHO_0*DRHO_1+UrhoDrho(3,1)*RHO_1*DRHO_0 tUDr(1)=tUDr(1)+UrhoDrho(0,0)*RHO_0+UrhoDrho(3,0)*RHO_1 tUr(2)=tUr(2)+UrhoDrho(1,0)*DRHO_1+UrhoDrho(1,2)*RHO_1*DRHO_1+UrhoDrho(0,2)*RHO_0*DRHO_0 & +UrhoDrho(3,0)*DRHO_0+UrhoDrho(3,2)*RHO_1*DRHO_0+UrhoDrho(2,2)*RHO_0*DRHO_1 tUDr(2)=tUDr(2)+UrhoDrho(1,0)*RHO_1+UrhoDrho(2,0)*RHO_0 ! tUr(1)=tUr(1)+Unablarho(0,1)*(SNABLAR_0**2+SNABLAZ_0**2)+Unablarho(1,1)*(SNABLAR_1**2+SNABLAZ_1**2) & !! (nabla rho)^2 +(Unablarho(2,1)+Unablarho(3,1))*(SNABLAR_0*SNABLAR_1+SNABLAZ_0*SNABLAZ_1) tUNr(1)=tUNr(1)+two*Unablarho(0,0)*SNABLAR_0+(Unablarho(2,0)+Unablarho(3,0))*SNABLAR_1 tUNz(1)=tUNz(1)+two*Unablarho(0,0)*SNABLAZ_0+(Unablarho(2,0)+Unablarho(3,0))*SNABLAZ_1 tUr(2)=tUr(2)+Unablarho(0,2)*(SNABLAR_0**2+SNABLAZ_0**2)+Unablarho(1,2)*(SNABLAR_1**2 & +SNABLAZ_1**2)+(Unablarho(2,2)+Unablarho(3,2))*(SNABLAR_0*SNABLAR_1+SNABLAZ_0*SNABLAZ_1) tUNr(2)=tUNr(2)+two*Unablarho(1,0)*SNABLAR_1+(Unablarho(2,0)+Unablarho(3,0))*SNABLAR_0 tUNz(2)=tUNz(2)+two*Unablarho(1,0)*SNABLAZ_1+(Unablarho(2,0)+Unablarho(3,0))*SNABLAZ_0 ! tUr(1)=tUr(1)+UrhonablaJ(0,0)*DJ_0+UrhonablaJ(0,1)*DJ_0*RHO_0+UrhonablaJ(1,1)*DJ_1*RHO_1 & !! rho nabla J +UrhonablaJ(2,0)*DJ_1+UrhonablaJ(2,1)*RHO_0*DJ_1+UrhonablaJ(3,1)*RHO_1*DJ_0 tUDj(1)=tUDj(1)+UrhonablaJ(0,0)*RHO_0+UrhonablaJ(3,0)*RHO_1 tUr(2)=tUr(2)+UrhonablaJ(1,0)*DJ_1+UrhonablaJ(1,2)*DJ_1*RHO_1+UrhonablaJ(0,2)*DJ_0*RHO_0 & +UrhonablaJ(3,0)*DJ_0+UrhonablaJ(3,2)*RHO_1*DJ_0+UrhonablaJ(2,2)*RHO_0*DJ_1 tUDj(2)=tUDj(2)+UrhonablaJ(1,0)*RHO_1+UrhonablaJ(2,0)*RHO_0 ! tUr(1)=tUr(1)+UJnablarho(0,1)*(SNABLAR_0*(SFIZ_0-SZFI_0)-SNABLAZ_0*(SFIR_0-SRFI_0)) !! J nabla rho tUr(1)=tUr(1)+UJnablarho(1,1)*(SNABLAR_1*(SFIZ_1-SZFI_1)-SNABLAZ_1*(SFIR_1-SRFI_1)) tUr(1)=tUr(1)+UJnablarho(2,1)*(SNABLAR_1*(SFIZ_0-SZFI_0)-SNABLAZ_1*(SFIR_0-SRFI_0)) tUr(1)=tUr(1)+UJnablarho(3,1)*(SNABLAR_0*(SFIZ_1-SZFI_1)-SNABLAZ_0*(SFIR_1-SRFI_1)) tUr(2)=tUr(2)+UJnablarho(0,2)*(SNABLAR_0*(SFIZ_0-SZFI_0)-SNABLAZ_0*(SFIR_0-SRFI_0)) tUr(2)=tUr(2)+UJnablarho(1,2)*(SNABLAR_1*(SFIZ_1-SZFI_1)-SNABLAZ_1*(SFIR_1-SRFI_1)) tUr(2)=tUr(2)+UJnablarho(2,2)*(SNABLAR_1*(SFIZ_0-SZFI_0)-SNABLAZ_1*(SFIR_0-SRFI_0)) tUr(2)=tUr(2)+UJnablarho(3,2)*(SNABLAR_0*(SFIZ_1-SZFI_1)-SNABLAZ_0*(SFIR_1-SRFI_1)) tUNr(1)=tUNr(1)+UJnablarho(0,0)*(SFIZ_0-SZFI_0) tUNr(2)=tUNr(2)+UJnablarho(1,0)*(SFIZ_1-SZFI_1) tUNz(1)=tUNz(1) -UJnablarho(0,0)*(SFIR_0-SRFI_0) tUNz(2)=tUNz(2) -UJnablarho(1,0)*(SFIR_1-SRFI_1) tUFIZ(1)=tUFIZ(1)+UJnablarho(0,0)*SNABLAR_0*half tUFIZ(2)=tUFIZ(2)+UJnablarho(1,0)*SNABLAR_1*half tUZFI(1)=tUZFI(1)-UJnablarho(0,0)*SNABLAR_0*half tUZFI(2)=tUZFI(2)-UJnablarho(1,0)*SNABLAR_1*half tURFI(1)=tURFI(1)+UJnablarho(0,0)*SNABLAZ_0*half tURFI(2)=tURFI(2)+UJnablarho(1,0)*SNABLAZ_1*half tUFIR(1)=tUFIR(1)-UJnablarho(0,0)*SNABLAZ_0*half tUFIR(2)=tUFIR(2)-UJnablarho(1,0)*SNABLAZ_1*half ! !! J.J (Mario: not tested for N2LO) tUr(1)=tUr(1)+UJJ(0,1)*J2_0+UJJ(1,1)*J2_1 & +(UJJ(3,1)+UJJ(2,1))*(SFIZ_0*SFIZ_1+SFIR_0*SFIR_1+SZFI_0*SZFI_1+SRFI_0*SRFI_1) tUr(2)=tUr(2)+UJJ(0,2)*J2_0+UJJ(1,2)*J2_1 & +(UJJ(3,2)+UJJ(2,2))*(SFIZ_0*SFIZ_1+SFIR_0*SFIR_1+SZFI_0*SZFI_1+SRFI_0*SRFI_1) tUFIZ(1)=tUFIZ(1)+UJJ(0,0)*SFIZ_0+half*(UJJ(3,0)+UJJ(2,0))*SFIZ_1 tUFIR(1)=tUFIR(1)+UJJ(0,0)*SFIR_0+half*(UJJ(3,0)+UJJ(2,0))*SFIR_1 tUZFI(1)=tUZFI(1)+UJJ(0,0)*SZFI_0+half*(UJJ(3,0)+UJJ(2,0))*SZFI_1 tURFI(1)=tURFI(1)+UJJ(0,0)*SRFI_0+half*(UJJ(3,0)+UJJ(2,0))*SRFI_1 tUFIZ(2)=tUFIZ(2)+UJJ(1,0)*SFIZ_1+half*(UJJ(3,0)+UJJ(2,0))*SFIZ_0 tUFIR(2)=tUFIR(2)+UJJ(1,0)*SFIR_1+half*(UJJ(3,0)+UJJ(2,0))*SFIR_0 tUZFI(2)=tUZFI(2)+UJJ(1,0)*SZFI_1+half*(UJJ(3,0)+UJJ(2,0))*SZFI_0 tURFI(2)=tURFI(2)+UJJ(1,0)*SRFI_1+half*(UJJ(3,0)+UJJ(2,0))*SRFI_0 ! tUr(1)=tUr(1)+UFnonstdr(0) !! other amplitudes tUr(2)=tUr(2)+UFnonstdr(1) ! !! External Field !! !!tUr(1)=tUr(1)+Vexternal(0,zero,fl(ihli),fh(ihli)) !!tUr(2)=tUr(2)+Vexternal(1,zero,fl(ihli),fh(ihli)) ! ! Contributions in the case 'u' depends on TAU_0 ! tUt(1)=tUt(1)+Urhotau(0,6)*RHO_0*TAU_0 & +Urhotau(1,6)*RHO_1*TAU_1+Urhotau(2,6)*RHO_0*TAU_1 & +Urhotau(3,6)*RHO_1*TAU_0+Urhorho(0,6)*RHO_0**2 & +Urhorho(1,6)*RHO_1**2+(Urhorho(2,6)+Urhorho(3,6))*RHO_0*RHO_1 & +UrhoDrho(0,6)*RHO_0*DRHO_0+UrhoDrho(1,6)*RHO_1*DRHO_1 & +UrhoDrho(2,6)*RHO_0*DRHO_1+UrhoDrho(3,6)*RHO_1*DRHO_0 & +Unablarho(0,6)*(SNABLAR_0*SNABLAR_0+SNABLAZ_0*SNABLAZ_0) & +Unablarho(1,6)*(SNABLAR_1*SNABLAR_1+SNABLAZ_1*SNABLAZ_1) & +(Unablarho(2,6)+Unablarho(3,6))*(SNABLAR_0*SNABLAR_1+SNABLAZ_0*SNABLAZ_1) & +UrhonablaJ(0,6)*RHO_0*DJ_0+UrhonablaJ(1,6)*RHO_1*DJ_1 & +UrhonablaJ(2,6)*RHO_0*DJ_1+UrhonablaJ(3,6)*RHO_1*DJ_0 & +UJnablarho(0,6)*(SNABLAR_0*(SFIZ_0-SZFI_0)-SNABLAZ_0*(SFIR_0-SRFI_0)) & +UJnablarho(1,6)*(SNABLAR_1*(SFIZ_1-SZFI_1)-SNABLAZ_1*(SFIR_1-SRFI_1)) & +UJnablarho(2,6)*(SNABLAR_1*(SFIZ_0-SZFI_0)-SNABLAZ_1*(SFIR_0-SRFI_0)) & +UJnablarho(3,6)*(SNABLAR_0*(SFIZ_1-SZFI_1)-SNABLAZ_0*(SFIR_1-SRFI_1)) tUt(1)=tUt(1)+UJJ(0,6)*J2_0+UJJ(1,6)*J2_1 & +(UJJ(2,6)+UJJ(3,6))*(SFIZ_0*SFIZ_1+SFIR_0*SFIR_1+SZFI_0*SZFI_1+SRFI_0*SRFI_1) ! ! Contributions in the case 'u' depends on DeltaRHO_0 ! tUDr(1)=tUDr(1)+Urhotau(0,7)*RHO_0*TAU_0 & +Urhotau(1,7)*RHO_1*TAU_1+Urhotau(2,7)*RHO_0*TAU_1 & +Urhotau(3,7)*RHO_1*TAU_0+Urhorho(0,7)*RHO_0**2 & +Urhorho(1,7)*RHO_1**2+(Urhorho(2,7)+Urhorho(3,7))*RHO_0*RHO_1 & +UrhoDrho(0,7)*RHO_0*DRHO_0+UrhoDrho(1,7)*RHO_1*DRHO_1 & +UrhoDrho(2,7)*RHO_0*DRHO_1+UrhoDrho(3,7)*RHO_1*DRHO_0 & +Unablarho(0,7)*(SNABLAR_0*SNABLAR_0+SNABLAZ_0*SNABLAZ_0) & +Unablarho(1,7)*(SNABLAR_1*SNABLAR_1+SNABLAZ_1*SNABLAZ_1) & +(Unablarho(2,7)+Unablarho(3,7))*(SNABLAR_0*SNABLAR_1+SNABLAZ_0*SNABLAZ_1) & +UrhonablaJ(0,7)*RHO_0*DJ_0+UrhonablaJ(1,7)*RHO_1*DJ_1 & +UrhonablaJ(2,7)*RHO_0*DJ_1+UrhonablaJ(3,7)*RHO_1*DJ_0 & +UJnablarho(0,7)*(SNABLAR_0*(SFIZ_0-SZFI_0)-SNABLAZ_0*(SFIR_0-SRFI_0)) & +UJnablarho(1,7)*(SNABLAR_1*(SFIZ_1-SZFI_1)-SNABLAZ_1*(SFIR_1-SRFI_1)) & +UJnablarho(2,7)*(SNABLAR_1*(SFIZ_0-SZFI_0)-SNABLAZ_1*(SFIR_0-SRFI_0)) & +UJnablarho(3,7)*(SNABLAR_0*(SFIZ_1-SZFI_1)-SNABLAZ_0*(SFIR_1-SRFI_1)) tUDr(1)=tUDr(1)+UJJ(0,7)*J2_0+UJJ(1,7)*J2_1 & +(UJJ(2,7)+UJJ(3,7))*(SFIZ_0*SFIZ_1+SFIR_0*SFIR_1+SZFI_0*SZFI_1+SRFI_0*SRFI_1) ! ! proton-neutron representation pUr(1) =tUr(1)+tUr(2); pUr(2) =tUr(1) -tUr(2) pUt(1) =tUt(1)+tUt(2)+hb0*facECM; pUt(2) =tUt(1) -tUt(2)+hb0*facECM pUDr(1) =tUDr(1)+tUDr(2); pUDr(2) =tUDr(1) -tUDr(2) pUNr(1) =tUNr(1)+tUNr(2); pUNr(2) =tUNr(1) -tUNr(2) pUNz(1) =tUNz(1)+tUNz(2); pUNz(2) =tUNz(1) -tUNz(2) pUDj(1) =tUDj(1)+tUDj(2); pUDj(2) =tUDj(1) -tUDj(2) pUFIZ(1)=tUFIZ(1)+tUFIZ(2); pUFIZ(2)=tUFIZ(1)-tUFIZ(2) pUZFI(1)=tUZFI(1)+tUZFI(2); pUZFI(2)=tUZFI(1)-tUZFI(2) pUFIR(1)=tUFIR(1)+tUFIR(2); pUFIR(2)=tUFIR(1)-tUFIR(2) pURFI(1)=tURFI(1)+tURFI(2); pURFI(2)=tURFI(1)-tURFI(2) ! Do it=itmin,itmax !! loop over n & p ita=3-it ! constraining potential If (numberCons.Gt.0) Then z=fh(ihli); rrr=fl(ihli)**2 Call moments_valueMesh(z,rrr,Qval) do icons=1,numberCons lambda=multLambda(icons); pUr(it)= pUr(it) - multLag(lambda)*Qval(lambda) end do End If ! coulomb If(it.Eq.2) Then If(icou.Ge.1) pUr(it)=pUr(it)+cou(ihli) If(icou.Eq.2) pUr(it)=pUr(it)+CExPar*coex*ro(ihli,it)**p13 End If ! pairing contribution to rearrangement term If(use_TMR_pairing.eq.0) then pUr(it)=pUr(it)-CpV0(it-1) *CpV1(it-1) /rho_c*aka(ihli,it)**2 & -CpV0(ita-1)*CpV1(ita-1)/rho_c*aka(ihli,ita)**2 endif ! pairing contribution to delta dv(ihli,it) rsa0=(ro(ihli,it)+ro(ihli,ita))/rho_c If(it.Eq.1) Then dvn(ihli)=(CpV0(it-1)*(ONE-rsa0*CpV1(it-1)))*aka(ihli,it) Else dvp(ihli)=(CpV0(it-1)*(ONE-rsa0*CpV1(it-1)))*aka(ihli,it) End If End Do !it ! vn(ihli)=pUr(1) ; vp(ihli)=pUr(2) !* RHO_ij vhbn(ihli)=pUt(1) ; vhbp(ihli)=pUt(2) !* TAU_ij vrn(ihli)=pUNr(1) ; vrp(ihli)=pUNr(2) !* NABLAr RHO__ij vzn(ihli)=pUNz(1) ; vzp(ihli)=pUNz(2) !* NABLAz RHO__ij vdn(ihli)=pUDr(1) ; vdp(ihli)=pUDr(2) !* DELTA RHO_ij vsn(ihli)=pUDj(1) ; vsp(ihli)=pUDj(2) !* NABLA . J__ij vSFIZn(ihli)=pUFIZ(1) ; vSFIZp(ihli)=pUFIZ(2) !* JFIZ_ij vSZFIn(ihli)=pUZFI(1) ; vSZFIp(ihli)=pUZFI(2) !* JZFI_ij vSFIRn(ihli)=pUFIR(1) ; vSFIRp(ihli)=pUFIR(2) !* JFIR_ij vSRFIn(ihli)=pURFI(1) ; vSRFIp(ihli)=pURFI(2) !* JRFI_ij ! End Do !ihli ! If (IDEBUG.Eq.1) Call get_CPU_time('field',1) ! End Subroutine field !=============================================================================================== ! !======================================================================= Subroutine gamdel !--------------------------------------------------------------------- ! ph- and pp- matrices in configurational space !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: i,ih,il,ib,ibx,nd,nd2,nza,nra,nla,nsa,nsb,nsab,icons,lambda Integer(ipr) :: ihil,laplus,im,JA,N1,N2,ndnd,n12,n21 Integer(ipr) :: i1,i2,i3 Real(pr) :: qla,yi,y,y2,qha,qhla,xmi,u2,un,up,xxx Real(pr) :: sml2,cnzaa,cnraa,SSU,SSD Real(pr) :: FITW1,FITW2,FITW3,FITW4 Real(pr) :: fi1r,fi1z,fi2d,QHL1A,QH1LA Real(pr) :: vh,vdh,vsh,hbh,vsum Real(pr) :: SRFIh,SFIRh,SFIZh,SZFIh,SNABLARh,SNABLAZh Real(pr) :: xlam,xlam2,xlamy,xlamy2,xlap,xlap2,xlapy,xlapy2,XLAMPY Real(pr) :: FIUN1,FIDN1,FIURN1,FIDRN1,FIUZN1,FIDZN1,FIUD2N1,FIDD2N1 Real(pr) :: FIUN2,FIDN2,FIURN2,FIDRN2,FIUZN2,FIDZN2,FIUD2N2,FIDD2N2 Real(pr) :: FIUN12,FIDN12,FIURN12,FIDRN12,FIUZN12,FIDZN12 Real(pr) :: vnhl,vrnhl,vznhl,vdnhl,vsnhl,vhbnhl,vSRFInhl,vSFIRnhl Real(pr) :: vSFIZnhl,vSZFInhl,vphl,vrphl,vzphl,vdphl,vsphl,vhbphl Real(pr) :: vSRFIphl,vSFIRphl,vSFIZphl,vSZFIphl,dvnhl,dvphl Integer(ipr) :: ibro Integer(ipr) :: ndxmax Parameter(ndxmax=(n00max+2)*(n00max+2)/4) Real(pr) :: OMPFIU(ndxmax),OMPFID(ndxmax),OMPFIUR(ndxmax),OMPFIDR(ndxmax),OMPFIUZ(ndxmax), & OMPFIDZ(ndxmax),OMPFIUD2N(ndxmax),OMPFIDD2N(ndxmax) ! If (IDEBUG.Eq.1) Call get_CPU_time('gamdel',0) ! !---------------------------------------------- ! START BLOCKS !---------------------------------------------- brout=zero; ibro=0 If (.Not. Allocated(allibro)) Then Allocate(allibro(1:NB)) allibro(1)=0 Do ib=2,NB allibro(ib) = allibro(ib-1) + (ID(ib-1)*(ID(ib-1)+1)/2) End Do End If !$OMP PARALLEL DO & !$OMP& DEFAULT(NONE) & !$OMP& SCHEDULE(DYNAMIC) & !$OMP& SHARED(NB,ID,IA,NBX,NS,nghl, & !$OMP& NHHDIM2,NHHDIM3,NHHDIM4,allibro, & !$OMP& vSRFIn,vSFIRn,vSFIZn,vSZFIn, & !$OMP& vSRFIp,vSFIRp,vSFIZp,vSZFIp, & !$OMP& vn,vrn,vzn,vdn,vsn,vhbn,dvn, & !$OMP& vp,vrp,vzp,vdp,vsp,vhbp,dvp, & !$OMP& QHLA_opt,FI1R_opt, FI1Z_opt, FI2D_opt, y_opt, & !$OMP& nhhdim,kindhfb,ALA2,RK,brout,Parity) & !$OMP& PRIVATE(I,ND,IB,IM,IBX,LAPLUS,XLAM,XLAP,XLAM2,IL,IH,IHIL,Y,Y2, & !$OMP& XLAMY,XLAMY2,XLAP2,XLAPY,XLAPY2,XLAMPY,N1,JA,NSA,SSU,SSD, & !$OMP& vnhl,vrnhl,vznhl,vdnhl,vsnhl,vhbnhl,dvnhl, & !$OMP& vphl,vrphl,vzphl,vdphl,vsphl,vhbphl,dvphl, & !$OMP& vSRFInhl,vSFIRnhl,vSFIZnhl,vSZFInhl,& !$OMP& vSRFIphl,vSFIRphl,vSFIZphl,vSZFIphl,& !$OMP& FI2D,i1,i2,i3,NSB,NSAB,SNABLARh, SNABLAZh,FI1R,FI1Z, & !$OMP& FIUD2N1,FIDD2N1,FIUD2N2,FIDD2N2,FITW3,FITW4,& !$OMP& OMPFIUD2N,OMPFIDD2N,OMPFIU,OMPFIUR,OMPFIUZ,OMPFID,OMPFIDR,OMPFIDZ, & !$OMP& FIUN1,FIDN1,FIURN1,FIDRN1,FIUZN1,FIDZN1,N2,FIUN2,FIDN2,FIURN2, & !$OMP& FIDRN2,FIUZN2,FIDZN2,FIUN12,FIDN12,FIURN12,FIDRN12,FIUZN12,FIDZN12,VH,& !$OMP& HBH,VDH,VSH,SRFIH,SFIRH,SFIZH,SZFIH,UN,UP,N12,QHLA) Do ib=1,NB ND=ID(ib); IM=ia(ib); ibx=ib+nbx If(Parity) Then LAPLUS=(ib+1)/2 !Yesp Else LAPLUS=ib !Nop End If XLAP=LAPLUS; XLAM=XLAP-ONE; xlap2=xlap*xlap; xlam2=xlam*xlam !---------------------------------------------- ! SUM OVER GAUSS INTEGRATION POINTS !---------------------------------------------- Do ihil=1,nghl y=y_opt(ihil); xlamy=xlam*y; xlapy=xlap*y; XLAMPY=XLAMY+XLAPY y2=y*y; xlamy2=xlam2*y2; xlapy2=xlap2*y2 ! vnhl=vn(ihil); vrnhl=vrn(ihil); vznhl=vzn(ihil); vdnhl=vdn(ihil) vsnhl=vsn(ihil); vhbnhl=vhbn(ihil); vSRFInhl=vSRFIn(IHIL); vSFIRnhl=vSFIRn(IHIL) vSFIZnhl=vSFIZn(IHIL); vSZFInhl=vSZFIn(IHIL); vphl=vp(ihil); vrphl=vrp(ihil) vzphl=vzp(ihil); vdphl=vdp(ihil); vsphl=vsp(ihil); vhbphl=vhbp(ihil) vSRFIphl=vSRFIp(IHIL); vSFIRphl=vSFIRp(IHIL); vSFIZphl=vSFIZp(IHIL); vSZFIphl=vSZFIp(IHIL) dvnhl=dvn(ihil); dvphl=dvp(ihil) ! Do N1=1,ND JA=IM+N1; NSA=NS(JA); SSU=Max(NSA,0); SSD=Max(-NSA,0) QHLA=QHLA_opt(JA,ihil); FI1R=FI1R_opt(JA,ihil); FI1Z=FI1Z_opt(JA,ihil); FI2D=FI2D_opt(JA,ihil) OMPFIU(N1)=QHLA*SSU; OMPFIUR(N1)=fi1r*SSU OMPFIUZ(N1)=fi1z*SSU; OMPFIUD2N(N1)=(FI2D-XLAMY2*QHLA)*SSU OMPFID(N1)=QHLA*SSD; OMPFIDR(N1)=fi1r*SSD OMPFIDZ(N1)=fi1z*SSD; OMPFIDD2N(N1)=(FI2D-XLAPY2*QHLA)*SSD End Do ! I=allibro(ib) Do N1=1,ND JA=IM+N1; NSA=NS(JA) FIUN1=OMPFIU(N1); FIURN1=OMPFIUR(N1); FIUZN1=OMPFIUZ(N1); FIUD2N1=OMPFIUD2N(N1) FIDN1=OMPFID(N1); FIDRN1=OMPFIDR(N1); FIDZN1=OMPFIDZ(N1); FIDD2N1=OMPFIDD2N(N1) Do N2=1,N1 I=I+1; i1=i+nhhdim; i2=i+nhhdim2; i3=i+nhhdim3; NSB=NS(N2+IM); NSAB=NSA+NSB If (NSAB.Ne.0) Then If (NSB.Gt.0) Then !spin:UpUp FIUN2 = OMPFIU(N2); FIURN2 = OMPFIUR(N2) FIUD2N2 = OMPFIUD2N(N2); FIUZN2 = OMPFIUZ(N2) vh = FIUN1*FIUN2 hbh = vh*XLAMY2+FIURN1*FIURN2+FIUZN1*FIUZN2 vdh = hbh+hbh+FIUN1*FIUD2N2+FIUN2*FIUD2N1 SNABLARh = FIURN1*FIUN2+FIURN2*FIUN1 SNABLAZh = FIUZN1*FIUN2+FIUZN2*FIUN1 vsh = SNABLARh*XLAMY SFIZh = (vh+vh)*XLAMY ! =SFIZh (v103) Else !spin:DoDo FIDN2 = OMPFID(N2); FIDRN2 = OMPFIDR(N2); FIDZN2 = OMPFIDZ(N2); FIDD2N2 = OMPFIDD2N(N2) vh = FIDN1*FIDN2 hbh = vh*XLAPY2+FIDRN1*FIDRN2+FIDZN1*FIDZN2 vdh = hbh+hbh+FIDN1*FIDD2N2+FIDN2*FIDD2N1; SNABLARh = FIDRN1*FIDN2+FIDRN2*FIDN1 SNABLAZh = FIDZN1*FIDN2+FIDZN2*FIDN1 vsh =-SNABLARh*XLAPY SFIZh =-(vh+vh)*XLAPY ! =SFIZh (v103) End If brout(i )=brout(i )+vSFIZnhl*SFIZh+vh*vnhl+SNABLARh*vrnhl+SNABLAZh*vznhl+vdh*vdnhl+vsh*vsnhl+hbh*vhbnhl brout(i1)=brout(i1)+vSFIZphl*SFIZh+vh*vphl+SNABLARh*vrphl+SNABLAZh*vzphl+vdh*vdphl+vsh*vsphl+hbh*vhbphl brout(i2)=brout(i2)+vh*dvnhl brout(i3)=brout(i3)+vh*dvphl Else If (NSB.Gt.0) Then !spin:DoUp !vh=ZERO; hbh=ZERO; vdh=ZERO; SNABLARh=ZERO; SNABLAZh=ZERO; SFIZh=ZERO FIUN2 = OMPFIU(N2); FIURN2 = OMPFIUR(N2); FIUD2N2 = OMPFIUD2N(N2); FIUZN2 = OMPFIUZ(N2) FITW3 =-FIDZN1*FIUN2; FITW4=FIUZN2*FIDN1 vsh =-FIDRN1*FIUZN2+FIURN2*FIDZN1+FITW3*XLAMY-FITW4*XLAPY SRFIh =-FIDRN1*FIUN2+FIURN2*FIDN1 SFIRh = FIDN1*FIUN2*XLAMPY SZFIh = FITW3+FITW4 Else !spin:UpDo !vh=ZERO; hbh=ZERO; vdh=ZERO; SNABLARh=ZERO; SNABLAZh=ZERO; SFIZh=ZERO FIDN2 = OMPFID(N2); FIDRN2 = OMPFIDR(N2); FIDZN2 = OMPFIDZ(N2); FIDD2N2 = OMPFIDD2N(N2) FITW3 =-FIDZN2*FIUN1; FITW4=FIUZN1*FIDN2 vsh = FIURN1*FIDZN2-FIDRN2*FIUZN1-FITW4*XLAPY+FITW3*XLAMY ! -vsh (v103) SRFIh = FIURN1*FIDN2-FIDRN2*FIUN1 !=SRFIh (v103) SFIRh = FIUN1*FIDN2*XLAMPY !=SFIRh(v103) SZFIh = FITW3+FITW4 !=SZFIh(v103) End If brout(i )=brout(i )+vsh*vsnhl+vSRFInhl*SRFIh+vSFIRnhl*SFIRh+vSZFInhl*SZFIh brout(i1)=brout(i1)+vsh*vsphl+vSRFIphl*SRFIh+vSFIRphl*SFIRh+vSZFIphl*SZFIh End If !---------------------------------------------- ! LN PH PART !---------------------------------------------- If(kindhfb.Lt.0) Then If(ihil.Eq.1) Then un=zero; up=zero; If(N1.Eq.N2) Then un=-ala2(1); up=-ala2(2) End If n12=N1+(N2-1)*ND brout(i )=brout(i )+two*(ala2(1)*rk(n12,ib )+un) brout(i1)=brout(i1)+two*(ala2(2)*rk(n12,ibx)+up) End If End If End Do !N2 End Do !N1 End Do !ihil End Do !IB !$OMP End Parallel Do If (IDEBUG.Eq.1) Call get_CPU_time('gamdel',1) ! ! Lagrange parameters for the constraints Do lambda=1,lambdaMax brout(nhhdim4+lambda)=multLag(lambda) End Do !---------------------------------------------- ! BROYDEN/LINEAR MIXING !---------------------------------------------- ! If (IDEBUG.Eq.1) Call get_CPU_time('broyden',0) ! Call broyden_min(nhhdim4+lambdaMax,brout,brin,alphamix,si,iiter,nbroyden,bbroyden) ! If (IDEBUG.Eq.1) Call get_CPU_time('broyden',1) ! Do lambda=1,lambdaMax multLag(lambda)=brin(nhhdim4+lambda) End Do ! End Subroutine gamdel !======================================================================= ! !====================================== ! lib PnProjected specIfics Start >>>>> !====================================== !======================================================================= Subroutine expectpj(lpr) !--------------------------------------------------------------------- ! calculates expectation values (tz is the particle number) ! optimized for half gauge-angle points !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Use UNEDF Implicit None Logical :: lpr,part_is_ready Integer(ipr) :: i,j,it,ihli,iw,iw1=901,iw2=902,icons,lambda Complex(pr) :: SZFIN,SFIZN,SRFIN,SFIRN,SZFIP,SFIZP,SRFIP,SFIRP Complex(pr) :: SFIZ_0,SFIR_0,SZFI_0,SRFI_0,SFIZ_1,SFIR_1,SZFI_1,SRFI_1 Complex(pr) :: RHO_0,RHO_1,TAU_0,TAU_1,DRHO_0,DRHO_1,DJ_0,DJ_1 Complex(pr) :: SNABLAR_0,SNABLAZ_0,SNABLAR_1,SNABLAZ_1 Complex(pr) :: cekt(3),cdel(2),cept(3),cetot,etens,cq2pj(ilpj,ilpj) Complex(pr) :: cxn(2),crms(3),cq2(3),cq4(3),xnpj(2),rmspj(3),q2pj(3),q4pj(3) Complex(pr) :: evolpj,esurpj,ecdipj,ecexpj,ecoupj,ept1pj,ept2pj,epotpj & ,eki1pj,eki2pj,ekinpj,etotpj,espopj,epa1pj,epa2pj,epirpj,ede1pj,ede2pj,etenspj & ,eva,ev3,ev5,es5,eso,ecodi,ecoex,rn,rp,rnp1,rnp2,rt,rt2,tnt,tpt,tt & ,dn,dp,dt,akn,akp,akn2,akp2,adn,adp,evol,esurf,ecoul,pijk,row,cx,dd1n,dd1p & ,rt1,tt1,dt1,djn,djp,djt,djt1 Complex(pr) :: rsa,rsa0,rsa0A,rps,rns,rsa1,rsa10,rsa12,rsa0An,rsa0As Real(pr) :: whl,x,xn(3),q4(3),def(3),bet2(3),het4(3),r212,r222,rc,z,zz,rrr,p2,p3,p4 Real(pr) :: rdelta(2),repair(3),rekin(3),revolpj,resurpj,respopj,recdipj,recexpj,retenspj ! Call densitpj ! calculates complex densities and the direct coulomb field ! evolpj = zero; esurpj = zero; ecdipj = zero; ecexpj = zero; espopj = zero; ept1pj = zero; ept2pj = zero; eki1pj = zero; eki2pj = zero; epj = zero; etotpj = zero; epa1pj = zero; epa2pj = zero; ede1pj = zero; ede2pj = zero; xnpj = zero; rmspj = zero; q2pj = zero; q4pj = zero; etenspj = zero; cq2pj = zero ! Do i=1,ilpj Do j=1,ilpj pijk = pjk(i,1)*pjk(j,2) ! cekt = zero; cept = zero; cdel = zero; cxn = zero; crms = zero; cq2 = zero; cq4 = zero; eva = zero; ev3 = zero; ev5 = zero; es5 = zero; eso = zero; ecodi = zero; ecoex = zero; etens = zero; ! Do ihli = 1,nghl ! real whl = wdcor(ihli) z = fh(ihli); zz = z*z; rrr = zz + fl(ihli)**2 p2 = p32*zz - half*rrr !3/2 z*z-1/2 (z*z+r*r)=1/2(2 z*z-r*2)=1/2 Q p3 = p53*z*p2 - p23*rrr*z p4 = p74*z*p3 - p34*rrr*p2 ! complex rn = ropj(ihli,i,1); rp = ropj(ihli,j,2); rnp2 = rn**2 + rp**2; rnp1=rn - rp ! ig - particle number, rms and deformations row = whl*rn; cxn(1)=cxn(1)+row; crms(1)=crms(1)+row*rrr; cq2(1)=cq2(1)+row*p2; cq4(1)=cq4(1)+row*p4 row = whl*rp; cxn(2)=cxn(2)+row; crms(2)=crms(2)+row*rrr; cq2(2)=cq2(2)+row*p2; cq4(2)=cq4(2)+row*p4 ! ig - energy contributions rt = rn + rp; rt2 = rt*rt tnt = taupj(ihli,i,1); tpt = taupj(ihli,j,2); tt = tnt + tpt dn = dropj(ihli,i,1); dp = dropj(ihli,j,2); dt = dn + dp akn = akapj(ihli,i,1); akp = akapj(ihli,j,2) akn2 = akn*akn; akp2 = akp*akp adn = akn*rn; adp = akp*rp ! ig-Pairing energy and delta rsa0=(rt/rho_c) dd1n=CpV0(0)*(ONE-rsa0*CpV1(0))*whl dd1p=CpV0(1)*(ONE-rsa0*CpV1(1))*whl ! cept(1) = cept(1) + dd1n*akn2; cept(2) = cept(2) + dd1p*akp2 cdel(1) = cdel(1) - dd1n*adn; cdel(2) = cdel(2) - dd1p*adp ! x = hb0*whl cekt(1) = cekt(1) + x*tnt; cekt(2) = cekt(2) + x*tpt !kinetic ev3 = ev3 + (tv1*rt2 - tv2*rnp2)*whl !volume eva = eva + (tv3*rt2-tv4*rnp2)*rt**sigma*whl ev5 = ev5 + (tv5*rt*tt + tv6*(rn*tnt + rp*tpt))*whl es5 = es5 + (ts1*rt*dt + ts2*(rn*dn + rp*dp))*whl !surface eso = eso + (CrdJ(0)*rt+CrdJ(1)*rnp1)*djpj(ihli,i,1)*whl !spin-orbit eso = eso + (CrdJ(0)*rt-CrdJ(1)*rnp1)*djpj(ihli,j,2)*whl !spin-orbit If(icou.Ge.1) ecodi = ecodi + half*coupj(ihli,j)*rp*whl !Coul.dir If(icou.Eq.2) ecoex = ecoex - cex*rp**t4o3*whl !Coul.exc If(use_j2terms) Then SFIZN=SFIZpj(IHLI,i,1); SFIRN=SFIRpj(IHLI,i,1); SZFIN=SZFIpj(IHLI,i,1); SRFIN=SRFIpj(IHLI,i,1) SFIZP=SFIZpj(IHLI,j,2); SFIRP=SFIRpj(IHLI,j,2); SZFIP=SZFIpj(IHLI,j,2); SRFIP=SRFIpj(IHLI,j,2) ETENS=ETENS+whl*(TA7*(SZFIN**2+SFIZN**2+SRFIN**2+SFIRN**2+SZFIP**2+SFIZP**2+SRFIP**2+SFIRP**2)& +TA8*(SZFIN*SZFIP+SFIZN*SFIZP+SRFIN*SRFIP+SFIRN*SFIRP)) End If End Do !ihli ! evol = ev3 + eva + ev5; esurf = es5; ecoul = ecodi + ecoex*CExPar cekt(3) = cekt(1) + cekt(2); cept(3) = cept(1) + cept(2) cetot = cekt(3) + evol + esurf + eso + ecoul + cept(3)+ ETENS cdel(1) = cdel(1)/tz(1); cdel(2) = cdel(2)/tz(2) !------------------------------------------------ ! half-projected energies required for the matrix elements !------------------------------------------------ epj(i,1) = epj(i,1) + cetot*pjk(j,2) epj(j,2) = epj(j,2) + cetot*pjk(i,1) !------------------------------------------------ ! for constraint contributions to half-projected energies !------------------------------------------------ If (icstr.Ne.0) cq2pj(i,j)=two*(cq2(1)+cq2(2)) !------------------------------------------------ ! projected energies !------------------------------------------------ evolpj = evolpj + pijk*evol; esurpj = esurpj + pijk*esurf; espopj = espopj + pijk*eso epa1pj = epa1pj + pijk*cept(1); epa2pj = epa2pj + pijk*cept(2); epirpj = epa1pj + epa2pj ede1pj = ede1pj + pijk*cdel(1); ede2pj = ede2pj + pijk*cdel(2) ecdipj = ecdipj + pijk*ecodi; ecexpj = ecexpj + pijk*ecoex; ecoupj = ecdipj + ecexpj ept1pj = ept1pj + pijk*cept(1); ept2pj = ept2pj + pijk*cept(2); epotpj = ept1pj + ept2pj eki1pj = eki1pj + pijk*cekt(1); eki2pj = eki2pj + pijk*cekt(2); ekinpj = eki1pj + eki2pj ! etotpj = etotpj + pijk*cetot etenspj= etenspj+ pijk*etens !------------------------------------------------ ! unprojected hfb total energy and constraint !------------------------------------------------ If(i.Eq.1.And.j.Eq.1) Then rehfbcan=Real(cetot,Kind=pr) End If ! ! projected particle numbers, rms, deformations If(j.Eq.1) Then xnpj(1) = xnpj(1) + pjk(i,1)*cxn(1) rmspj(1) = rmspj(1) + pjk(i,1)*crms(1) q2pj(1) = q2pj(1) + pjk(i,1)*cq2(1) q4pj(1) = q4pj(1) + pjk(i,1)*cq4(1) End If If(i.Eq.1) Then xnpj(2) = xnpj(2) + pjk(j,2)*cxn(2) rmspj(2) = rmspj(2) + pjk(j,2)*crms(2) q2pj(2) = q2pj(2) + pjk(j,2)*cq2(2) q4pj(2) = q4pj(2) + pjk(j,2)*cq4(2) End If ! End Do !j End Do !i ! ! Real quantities to the end ! !------------------------------------------------ ! Energies !------------------------------------------------ rdelta(1) = Real(ede1pj,Kind=pr); rdelta(2) = Real(ede2pj,Kind=pr); retotpj = Real(etotpj,Kind=pr); repair(1) = Real(epa1pj,Kind=pr); repair(2) = Real(epa2pj,Kind=pr); repair(3) = Real(epirpj,Kind=pr) rekin(1) = Real(eki1pj,Kind=pr); rekin(2) = Real(eki2pj,Kind=pr); rekin(3) = Real(ekinpj,Kind=pr) revolpj = Real(evolpj,Kind=pr); resurpj = Real(esurpj,Kind=pr); respopj = Real(espopj,Kind=pr); recdipj = Real(ecdipj,Kind=pr); recexpj = Real(ecexpj,Kind=pr); retenspj = Real(etenspj,Kind=pr); depnp = retotpj - rehfbcan !correlation energy due to projection !------------------------------------------------ ! expectation values of multipole moments !------------------------------------------------ Call moments_computeValue() !------------------------------------------------ ! rms and deformations !------------------------------------------------ Do it=itmin,itmax xn(it) = Real(xnpj(it),Kind=pr) rms(it)= Sqrt(Real(rmspj(it),Kind=pr)/xn(it)) q2(it) = two*Real(q2pj(it),Kind=pr) !Qnp=<2r^2P_2(teta)>=<2z^2-x^2-y^2> q4(it) = ffdef4*Real(q4pj(it),Kind=pr) !Hn=<8r^4P_4(teta)>=<8z^4-24z^2(x^2+y^2)+3(x^2+y^2)^2> def(it)= Sqrt(pi/5.0_pr)*q2(it)/(rms(it)**2*xn(it)) End Do r212 = rms(1)**2; r222 = rms(2)**2 rms(3) = Sqrt((xn(1)*r212+xn(2)*r222)/amas) q2(3) = q2(1) + q2(2) ! quadrupole moment q4(3) = q4(1) + q4(2) ! hexadecapole moment def(3) = Sqrt(pi/5.0_pr)*q2(3)/(rms(3)**2*amas) !deformation !------------------------------------------------ ! other definitions of the same quantities !------------------------------------------------ bet2(1) = ffdef6*q2(1)/(xn(1)*r02) !beta_n=Qn*Sqrt(5Pi)/(3N x^2) bet2(2) = ffdef6*q2(2)/(xn(2)*r02) !x=r0=1.2A^(1/3) bet2(3) = ffdef6*q2(3)/(amas*r02) het4(1) = ffdef7*q4(1)/(xn(1)*r04) het4(2) = ffdef7*q4(2)/(xn(2)*r04) het4(3) = ffdef7*q4(3)/(amas*r04) xn(3) = xn(1) + xn(2) bet = def(3) !------------------------------------------------ ! constraint constants and contributions to half-projected energies !------------------------------------------------ If(icstr.Ne.0) Then cx=0.0_pr If (numberCons.Gt.0) Then Do icons=1,numberCons lambda=multLambda(icons) cx = cx - multLag(lambda)*(qmoment(lambda,3)-multRequested(lambda)) End Do End If !ty20=Sqrt(5.0_pr/pi)*hom/b0**2/two !cx=cqad*(cdef-bet)*ty20; Do i=1,ilpj Do j=1,ilpj epj(i,1) = epj(i,1) + cx*cq2pj(i,j)*pjk(j,2) epj(j,2) = epj(j,2) + cx*cq2pj(i,j)*pjk(i,1) End Do End Do End If ! If (lpr) Then rc=Sqrt(r222+0.640_pr) ! transitions to barn,barn^2,barn^4 Do i=1,3 q2(i)=q2(i)/100.0_pr; q4(i)=q4(i)/10000.0_pr End Do ! ! STORE to projected buffer 'eresj' ! ieresj=50 from module definitions ! ' si ','JININ' eresj(1)=si; eresj(2)=inin; ! ' A',' N ',' Z ' eresj(3)=npr(1)+npr(2); eresj(4)=npr(1); eresj(5)=npr(2); ! ' Jln ',' Jlp ' eresj(6)=alast(1); eresj(7)=alast(2); ! ,'JEtot','Jbett','Jbetn','Jbetp',' JQt ',' JQn ',' JQp ' & eresj(8)=retotpj; eresj(9)=def(3); eresj(10)=def(1); eresj(11)=def(2); eresj(12)=q2(3); eresj(13)=q2(1); eresj(14)=q2(2); ! ' JpEn',' JpEp',' JpDn',' JpDp',' JAsn',' JAsp' & eresj(15)=repair(1); eresj(16)=repair(2); eresj(17)=rdelta(1); eresj(18)=rdelta(2); eresj(19)=ass(1); eresj(20)=ass(2); ! ,' Jrt ',' Jrn ',' Jrp ',' Jrc ',' Jht ',' Jhn ',' Jhp ' & eresj(21)=rms(3); eresj(22)=rms(1); eresj(23)=rms(2); eresj(24)=rc; eresj(25)=het4(3); eresj(26)=het4(1); eresj(27)=het4(2); ! ,' Jqht',' Jqhn',' Jqhp' & eresj(28)=q4(3); eresj(29)=q4(1); eresj(30)=q4(2); ! ,' JKINt',' JKINn','JKINp',' JSO ','JCDIR',' JCEX','JDisn','JDisp' & eresj(31)=rekin(3); eresj(32)=rekin(1); eresj(33)=rekin(2); eresj(34)=respopj; eresj(35)=recdipj; eresj(36)=recexpj; eresj(37)=Dispersion(1); eresj(38)=Dispersion(2); ! ,'JV2Mn','JV2Mp','JILST','JKIND',' JL ' & eresj(39)=v2min(1); eresj(40)=v2min(2) eresj(41)=iLST; eresj(42)=kindhfb; eresj(43)=iLpj; ! ,'JECMPAV','JECMPAV','JECMPAV' eresj(44)=ECMPAV(3); eresj(45)=ECMPAV(1); eresj(46)=ECMPAV(2); ! 'JA','JN',JZ' eresj(47)=Nint(xn(3)); eresj(48)=Nint(xn(1)); eresj(49)=Nint(xn(2)); ! 'iter' eresj(50)=iiter ! nucleus with wrong asymptotic If(iasswrong(3).Ne.0) eresj(21)=-eresj(21) ! ! WRITE to screen 'lout' and tape akzout.dat 'lfile' Do iw=lout,lfile Write(iw,*) Write(iw,'(a,9x,a,/)') ' NB! From expectpj (PNP PAV RESULTS)' Write(iw,*) If(iLST1.Ne.0) & Write(iw,'(a,6f15.6)') ' hfb decay const. ass ',ass Write(iw,'(a,8f15.6)') ' pairing: CpV0,CpV1,pwi... ',CpV0,CpV1,pwi Write(iw,'(a,a,a,i3)') ' forces: ',skyrme,', Gauge points:',ilpj If(keyblo(1).Ne.0) & Write(iw,'(a,i4,a,f10.3)') ' Blocked neutron block ', & bloblo(keyblo(1),1) If(keyblo(2).Ne.0) & Write(iw,'(a,i4,a,f10.3)') ' Blocked proton block ', & bloblo(keyblo(2),2) Write(iw,*) Write(iw,'(/,28x,a,8x,a,9x,a)') ' neutrons ','protons','total' Write(iw,'(a,6f15.6)') ' Requested part.numbs.',tz,Sum(tz) Write(iw,'(a,6f15.6)') ' Projected part.numbs.',xn Write(iw,'(a,3f15.6)') ' Dispersion dN2 ......',Dispersion Write(iw,'(a,6f15.6)') ' b0, bz, bp ..........',b0,bz,bp Write(iw,*) Write(iw,'(a,6f15.6)') ' lambda (ala) ........',ala Write(iw,'(a,6f15.6)') ' Lambda (alast) ......',alast Write(iw,'(a,6f15.6)') ' delta(n,p) ..........',rdelta Write(iw,'(a,6f15.6)') ' pairing energy ......',repair Write(iw,*) Write(iw,'(a,6f15.6)') ' rms-radius ..........',rms Write(iw,'(a,15x,2f15.6)') ' charge-radius, r0 ...',rc,r00 Write(iw,'(a,6f15.6)') ' deformation beta2 ...',def Write(iw,'(a,6f15.6)') ' quadrupole moment[b] ',q2 Write(iw,'(a,6f15.6)') ' hexadecapole moment .',q4 Write(iw,*) Write(iw,'(a,6f15.6)') ' kinetic energy ......',rekin Write(iw,'(a,6f15.6)') ' cmc-diagonal part ...',rekin/hb0*hbzero-rekin Write(iw,'(a,6f15.6)') ' cmc-PAV .............',ECMPAV Write(iw,*) Write(iw,'(a,30x,6f15.6)') ' volume energy .......',revolpj Write(iw,'(a,30x,6f15.6)') ' surface energy ......',resurpj Write(iw,'(a,30x,6f15.6)') ' spin-orbit energy ...',respopj Write(iw,'(a,30x,6f15.6)') ' coulomb direct ......',recdipj Write(iw,'(a,30x,6f15.6)') ' coulomb exchange ....',recexpj Write(iw,'(a,30x,6f15.6)') ' tensor energy .......',retenspj Write(iw,*) Write(iw,'(a,30x,f15.6)') ' Energy: ehfb(qp) ....',ehfb Write(iw,'(a,30x,f15.6)') ' Energy: ehfb(can,pj).',rehfbcan Write(iw,'(a,30x,f15.6)') ' ehfb(qp)-ehfb(can,pj)',ehfb-rehfbcan Write(iw,'(a,30x,f15.6)') ' Epj-ehfb(can,pj) ....',depnp Write(iw,'(a,30x,6f15.6)') ' Energy: Epj=E(PAV) ..',retotpj Write(iw,*) End Do ! ! APPEND the results to file 'thodef.dat' ! ieres=ieresu+ieresl+ieresj+ierebl from module definitions If(iappend.Ne.0) Then ierest=0 ! charge buffers Do i=1,ieresj !charge projected buffer ierest=ierest+1 eres(ierest)=eresj(i) End Do Do i=1,ieresu !charge unprojected buffer ierest=ierest+1 eres(ierest)=eresu(i) End Do Do i=1,ieresl !charge LN buffer ierest=ierest+1 eres(ierest)=eresl(i) End Do Do i=1,ieresbl !charge Blocking buffer ierest=ierest+1 eres(ierest)=eresbl(i) End Do If(ierest.Ne.ieres) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: In expectpj: ierest wrong' Return End If If(Print_Screen) Then ! recording results 100 Continue ! complications are due to eagle_ornl If(iLST1.Le.0) Then Open (unit=iw2,file='hodef.dat',err=100,iostat=i,position='append') Write(iw2,'(3(1x,a,1x),160(1x,f14.6))') nucname,ereslbl,eres(1:ierest) Close(iw2) Else If (iasswrong(3).Eq.0) Then Open (unit=iw1,file='thodef.dat',err=100,iostat=i,position='append') Write(iw1,'(3(1x,a,1x),160(1x,f14.6))') nucname,ereslbl,eres(1:ierest) Close(iw1) End If End If End If End If End If ! End Subroutine expectpj !======================================================================= ! !======================================================================= Subroutine densitpj !--------------------------------------------------------------------- ! calculate local densities ! calculate local densities in mixed canonical (\for rho C, Y) and ! qp (for\tilde{\rho}) representation therefore E(can) \equiv E(qp) !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Use UNEDF Implicit None ! Complex(pr) :: tpfiu1,tpfid1,v2ig,dig,sumsum Complex(pr), Allocatable :: ank1(:,:),pfiun1(:,:),pfidn1(:,:) Complex(pr), Allocatable :: pakapj(:),propj(:), pdjpj(:), ptaupj(:),pdropj(:) Complex(pr), Allocatable :: pszfipj(:),psfizpj(:),psrfipj(:),psfirpj(:) Complex(pr), Pointer:: ppjk(:),pcpj(:,:),prpj(:,:),pypj(:,:) Real(pr) :: f,s,sd,su,sud,y,y2,sml2,cnzaa,cnraa,u,v2,tauin,xxx,yyy Real(pr) :: aav,anik,anik2,qhla,qh1la,qhl1a,qla,qha,fi1r,fi1z,fi2d Real(pr) :: xlam,xlam2,xlamy,xlamy2,xlap,xlap2,xlapy,xlapy2,xlampy Real(pr) :: tfiu,tfid,tfiur,tfidr,tfiuz,tfidz,tfiud2,tfidd2,tpfiu2,tpfid2,TW_T Real(pr), Allocatable :: an2(:),ank2(:),pfiun2(:),pfidn2(:) Integer(ipr) :: iw,nsa,nza,nra,nla,k,i,nd,il,ih,ihil,laplus,kkymu,n12 Integer(ipr) :: imen,ib,m,im,ig,it,j,jj,ja,jn,ILIHLI,k1,k2,kkk,kky,mu,kkkmu Integer(ipr) :: k0(2),ky(2),kk(nqx),kyk(nqx) ! Allocate(ank1(nqx,ilpj),pfiun1(ndx,ilpj),pfidn1(ndx,ilpj)) Allocate(pfiun2(ndx),pfidn2(ndx),an2(nqx),ank2(nqx)) Allocate(pakapj(ilnghl),propj(ilnghl), pdjpj(ilnghl), ptaupj(ilnghl),pdropj(ilnghl), & pSZFIpj(ilnghl),pSFIZpj(ilnghl),pSRFIpj(ilnghl),pSFIRpj(ilnghl)) ! ! Projection grid points ! keypj=max(1,keypj); ilpj=keypj; ilpj2=ilpj**2 !all ! when a value two*pi is used the results are precisely the same ! but the accuracy for even L is slow with increasing L. ! when 'pi' is used it gives regular and better convergence ! with respect to both, odd and even, L. ! Write(*,'(2x,a,i2,a,f12.8,a,f12.8)') 'point ig= ',i,' phi= ',yyy,' pi/2= ',pi/two xxx = pi/Real(ilpj,Kind=pr) ! equivalent to xxx = two*pi/Real(ilpj) Do i=1,ilpj yyy = Real(i-1,Kind=pr)*xxx phypj(i) = onei*yyy sinphy(i) = onei*Sin(yyy) exp1iphy(i) = Exp(onei*yyy) exp1iphym(i) = Exp(-onei*yyy) exp2iphy(i) = Exp(two*onei*yyy) exp2iphym(i) = Exp(-two*onei*yyy) End Do ! ! initialize parameters varmas = zero ! Do it=itmin,itmax ! ! zero for densities Do J=1,ilnghl pakapj(J)=zero; propj(J)=zero; pdjpj(J)=zero; ptaupj(J)=zero; pdropj(J)=zero; End Do Do J=1,ilnghl pszfipj(J)=zero; psfizpj(J)=zero; psrfipj(J)=zero; psfirpj(J)=zero; End Do ! ! it-pointers prpj => rpj(:,:,it); pcpj => cpj(:,:,it); pypj => ypj(:,:,it); ppjk => pjk(:,it); ! ! null for all pointers pypj=zero; prpj=zero; pcpj=zero; ppjk=one; ! ! particle-init (kkk-even: 2 x number of pairs) kkk=npr(it); If(kkk.Ne.2*(kkk/2)) kkk=npr(it)-1 ppjk(1:ilpj)=exp1iphym(1:ilpj)**kkk ! ! start blocks k0(it)=0; ky(it)=0 Do ib=1,nb nd=id(ib); im=ia(ib) If(Parity) Then LAPLUS=(ib+1)/2 !Yesp Else LAPLUS=ib !Nop End If xlap=laplus; xlap2=xlap*xlap; xlam=xlap-one; xlam2=xlam*xlam ! ! charge block can quantities m=ib+(it-1)*nbx; k1=ka(ib,it)+1; k2=ka(ib,it)+kd(ib,it); imen=0 If(k1.Le.k2) Then ! below the pwi cut-off imen = nd !lcanon(ib,it)=lc Do k = 1,nd k0(it) = k0(it) + 1; kk(k) = k0(it); kkk = k0(it) ky(it) = ky(it) + 1; kyk(k) = ky(it); kky = ky(it) aav = vk(kkk,it) ! v^2 Do ig=1,ilpj v2ig = exp2iphy(ig)*aav ! gauged v^2 dig = one - aav + v2ig ! denominator If(kkk.Ne.blocanon(it)) Then ppjk(ig) = ppjk(ig)*dig ! y(ig,it) <<<<< End If prpj(kkk,ig) = v2ig/dig ! rho(mu,ig,it) pcpj(kky,ig) = exp2iphy(ig)/dig ! c(mu,ig,it) pypj(kky,ig) = exp1iphy(ig)/dig*onei*Sin(phypj(ig)/onei) ! sinphy(ig) !Y(mu,ig,it) End Do End Do ! At this point density (and related) are strictly equivalent in qp- and can-representation ! (up to 10^-14). Pairing density is not so strict (up to 10^-5) due to uv from v^2 but ! pairing density is taken directly in qp representation so both representations ! qp and can are strictly exact (up to 10^-14). j=0 Do jj = 1,nd Do k = 1,nd j=j+1; n12 = jj+(k-1)*nd; an2(j) = ddc(jj,kk(k),it) ank2(j) = ak(n12,m) ! half \tilde{\rho} in q.p. basis Do ig=1,ilpj ank1(j,ig) = zero End Do Do mu=1,nd ! for half e^(-i\phy)*C(\phy)*\tilde{\rho} in q.p. basis kkkmu = kk(mu); kkymu=kyk(mu) Do ig=1,ilpj ! e^(-i\phy)*C in q.p. basis ank1(j,ig) = ank1(j,ig) + ddc(jj,kkkmu,it)*ddc(k,kkkmu,it)*pcpj(kkymu,ig)*exp1iphym(ig) End Do End Do End Do End Do Else ! above the pwi cut-off (NB! Attention) ! here imem=0 and the contribution does ! not enter the densities but the Hamiltonian matrix ! used only in VAP regime ky(it)=ky(it)+1; kky = ky(it) Do ig=1,ilpj pcpj(kky,ig) = exp2iphy(ig) pypj(kky,ig) = exp1iphy(ig)*sinphy(ig) End Do End If ! ! calculate the densities only below the PWI cutoff If (imen.Gt.0) Then ! gauss integration points Do il=1,ngl v2 = half/xl(il) Do ih=1,ngh ihil = ih + (il-1)*ngh; ilihli=(ihil-1)*ilpj !u = xh(ih); y = fli(ihil); y2=y*y u = xh(ih); y = y_opt(ihil); y2=y*y xlamy=xlam*y; xlamy2=xlam2*y2; xlapy=xlap*y; xlapy2=xlap2*y2; xlampy=xlamy+xlapy ! ! initialize spin up/down funct Do k=1,nd fiu(k)=zero; fiuz(k)=zero; fiur(k)=zero; fiud2n(k)=zero; pfiun2(k)=zero; fid(k)=zero; fidz(k)=zero; fidr(k)=zero; fidd2n(k)=zero; pfidn2(k)=zero; Do ig=1,ilpj pfiun1(k,ig)=zero; pfidn1(k,ig)=zero End Do End Do ! ! scan over basis states jn=0 Do i=1,nd ja = i+im; nla = nl(ja); nra = nr(ja); nza = nz(ja); nsa = ns(ja); sml2 = nla*nla; cnzaa = nza+nza+1; cnraa = nra+nra+nla+1 QHLA=QHLA_opt(JA,ihil); FI2D=FI2D_opt(JA,ihil) FI1Z=FI1Z_opt(JA,ihil); FI1R=FI1R_opt(JA,ihil) !qha = qh(nza,ih); qla = ql(nra,nla,il); qhla = qha*qla !qhl1a = qha*ql1(nra,nla,il)*v2; qh1la = qh1(nza,ih)*qla !fi1z = fp1(ihil)*qhla+fp2(ihil)*qh1la+fp3(ihil)*qhl1a !fi1r = fp4(ihil)*qhla+fp5(ihil)*qh1la+fp6(ihil)*qhl1a !fi2d = (fs1(ihil)*qh1la**2 + four*fs4(ihil)*qh1la*qhl1a & ! + fs2(ihil)*qhl1a**2 + two*(fs5(ihil)*qh1la & ! + fs6(ihil)*qhl1a)*qhla + ((u*u - cnzaa)*fs1(ihil) & ! + (p14-cnraa*v2+sml2*v2*v2)*fs2(ihil)+fs3(ihil))*qhla**2 & ! - two*(fi1r**2+fi1z**2))/(two*qhla) ! ! wave function(spin:up,down; grad:r,z,d2) If (nsa.Gt.0) Then Do k=1,nd jn = jn+1; anik = an2(jn); anik2 = ank2(jn) Do ig=1,ilpj pfiun1(k,ig) = pfiun1(k,ig) + ank1(jn,ig)*qhla End Do pfiun2(k) = pfiun2(k) + anik2*qhla fiu(k) = fiu(k) + anik*qhla fiur(k) = fiur(k) + anik*fi1r fiuz(k) = fiuz(k) + anik*fi1z fiud2n(k) = fiud2n(k) + anik*fi2d ! End Do Else Do k=1,nd jn = jn+1; anik = an2(jn); anik2 = ank2(jn) Do ig=1,ilpj pfidn1(k,ig) = pfidn1(k,ig) + ank1(jn,ig)*qhla End Do pfidn2(k) = pfidn2(k) + anik2*qhla fid(k) = fid(k) + anik*qhla fidr(k) = fidr(k) + anik*fi1r fidz(k) = fidz(k) + anik*fi1z fidd2n(k) = fidd2n(k) + anik*fi2d ! End Do End If End Do ! i ! ! calculate densities Do k=1,nd kkk =kk(k) tfiu=fiu(k); tfiuz=fiuz(k); tfiur=fiur(k); tfiud2=fiud2n(k); tpfiu2=pfiun2(k); tfid=fid(k); tfidz=fidz(k); tfidr=fidr(k); tfidd2=fidd2n(k); tpfid2=pfidn2(k); Do ig=1,ilpj I=ig+ilihli; v2ig=prpj(kkk,ig); tpfiu1=pfiun1(k,ig); tpfid1=pfidn1(k,ig) ! pakapj(I) = pakapj(I) + (tpfiu1*tpfiu2+tpfid1*tpfid2) propj(I) = propj(I) + (tfiu**2+tfid**2)*v2ig pdjpj(I) = pdjpj(I) + (tfiur*tfidz-tfidr*tfiuz+xlamy*tfiu*(tfiur-tfidz) & - xlapy*tfid*(tfidr+tfiuz))*v2ig TW_T=(tfiur**2+tfidr**2+tfiuz**2+tfidz**2) tauin = (xlamy2*tfiu**2+xlapy2*tfid**2+TW_T) ptaupj(I) = ptaupj(I) + tauin*v2ig pdropj(I) = pdropj(I) + (TW_T + tfiu*tfiud2 + tfid*tfidd2)*v2ig psrfipj(I) = psrfipj(I) + (tfiur*tfid - tfidr*tfiu)*v2ig psfirpj(I) = psfirpj(I) + (tfiu*tfid*xlampy)*v2ig psfizpj(I) = psfizpj(I) + (xlamy*tfiu**2 - xlapy*tfid**2)*v2ig pszfipj(I) = pszfipj(I) + (tfiuz*tfid - tfidz*tfiu)*v2ig ! End Do !ig End Do !k End Do !ih End Do !il End If End Do !ib ! ! normalized pjk sumsum = Sum(ppjk(1:ilpj)); ppjk(1:ilpj) = ppjk(1:ilpj)/sumsum ! ! Y minus second term of Y Do k=1,ky(it) sumsum = Sum(ppjk(1:ilpj)*pypj(k,1:ilpj)) pypj(k,1:ilpj) = pypj(k,1:ilpj) - sumsum End Do ! ! norm of the projected/unprojected density s = zero; sd = zero; su = zero; sud = zero; Do ihil=1,nghl ilihli=(ihil-1)*ilpj Do ig=1,ilpj I=ig+ilihli s=s+Real(two*propj(I)*ppjk(ig)); sd=sd+Real(four*pdropj(I)*ppjk(ig)) End Do I=1+ilihli su=su+Real(two*propj(I)); sud=sud+Real(four*pdropj(I)) End Do ! ! print unprojected normalization Do iw=lout,lfile Write(iw,'(2(a,2(2x,D15.8)),(a,D15.8),a,i3)') & ' pj/unpj s= ',s,su,' pj/unpj sd= ',sd,sud,' ala1= ',ala1(it),' inner= ',inner(it) End Do varmas = varmas + su varmasNZ(it) = su; pjmassNZ(it) = s ! s = Real(npr(it),Kind=pr)/s; dnfactor(it) = s; drhoi(it) = sd ! Do ihil = 1,nghl ilihli=(ihil-1)*ilpj ! wdcor moves out the int.weight and multiply by the jacobian f = two*wdcori(ihil) Do ig=1,ilpj I=ig+ilihli ropj (ihil,ig,it) = f*propj (I) taupj(ihil,ig,it) = f*ptaupj(I) dropj(ihil,ig,it) = f*pdropj(I)*two djpj (ihil,ig,it) = f*pdjpj (I)*two akapj(ihil,ig,it) = f*pakapj(I)*half SRFIpj(ihil,ig,it) = f*psrfipj(I) SFIRpj(ihil,ig,it) = f*psfirpj(I) SFIZpj(ihil,ig,it) = f*psfizpj(I) SZFIpj(ihil,ig,it) = f*pszfipj(I) End Do !ig End Do !ihil ! End Do !it ! dnfactor(3)=dnfactor(1)+dnfactor(2) ! Deallocate(ank1,pfiun1,pfidn1) Deallocate(pakapj,propj, pdjpj, ptaupj,pdropj,pSZFIpj,pSFIZpj,pSRFIpj,pSFIRpj) ! Call coulompj !complex coulomb fields ! End Subroutine densitpj !======================================================================= ! !======================================================================= Subroutine coulompj !--------------------------------------------------------------------- ! Coulom-field (direct part) !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: i,j,k Real(pr) :: zd2,y1,y2,xx1,s1,vik,f,r,r1,rr2,z,z1,zd1,t Real(pr) :: bb,r2,r12,rrr,rz1,rz2,rrz1,rrz2,xx Real(pr) :: bb1=3.5156229_pr,g1=0.39894228_pr,g7=0.02635537_pr, & bb2=3.0899424_pr,g2=0.01328592_pr,g8=0.01647633_pr, & bb3=1.2067492_pr,g3=0.00225319_pr,g9=0.00392377_pr, & bb4=0.2659732_pr,g4=0.00157565_pr,bbxx=3.750_pr, & bb5=0.0360768_pr,g5=0.00916281_pr, & bb6=0.0045813_pr,g6=0.02057706_pr If(icacoupj.Eq.0) Then icacoupj = 1; bb = Max(bp,bz)**4; f = chargee2/Sqrt(pi); ! f=e^2/Sqrt(pi) Do i = 1,nghl r = fl(i); z = fh(i); r2 = r*r Do k = 1,i r1 = fl(k); z1 = fh(k); r12 = r1*r1 rrr = two*r*r1; rr2 = (r - r1)**2 zd1 = (z - z1)**2; zd2 = (z + z1)**2 rz1 = r2+r12+zd1; rz2 = r2+r12+zd2 rrz1 = rr2+zd1; rrz2 = rr2+zd2 ! xx1=zero Do j=1,nleg xx=Sqrt(one-xleg(j)**2); y1=(xleg(j)/(bb*xx))**2; s1=y1*rrr If(s1.Le.bbxx) Then t=(s1/bbxx)**2; y2=one+t*(bb1+t*(bb2+t*(bb3+t*(bb4+t*(bb5+t*bb6))))) y2=y2*(Exp(-rz1*y1)+Exp(-rz2*y1)) Else t=(bbxx/s1); y2=g1+t*(g2+t*(g3+t*(-g4+t*(g5+t*(-g6+t*(g7+t*(-g8+t*g9))))))) y2=y2/Sqrt(s1)*(Exp(-rrz1*y1)+Exp(-rrz2*y1)) End If xx1 = xx1 + wleg(j)*y2/(bb*xx**3) End Do vik=f*xx1; vc(i,k)=vik*wdcor(k); vc(k,i)=vik*wdcor(i) !wdcor=pi*wh*wl*bz*bp*bp/fd End Do !k End Do !i End If ! calculation of the coulomb field coupj = zero Do i = 1,nghl Do k=1,ilpj coupj(:,k) = coupj(:,k) + vc(:,i)*ropj(i,k,2) End Do End Do End Subroutine coulompj !======================================================================= ! !======================================================================= Subroutine broyden_min(N,vout,vin,alpha,si,iter,M,bbroyden) !--------------------------------------------------------------------- ! Modified Broyden's method: D.D.Johnson, PRB 38, 12807 (1988) ! Adopted from: (C) 2001 PWSCF group ! Input : ! N dimension of arrays vin,vout ! vin outpu at previous iteration ! vout output at current iteration ! alpha mixing factor (0 < alpha <= 1) ! iter current iteration number ! M number of iterations in Broyden history ! M=0 Linear mixing ! Output: ! si MaxVal(|vout-vin|) ! vin Broyden/Linear mixing result ! vout vout-vin ! bbroyden='B' Broyden mixing, curvature>0 ! bbroyden='L' Linear mixing, curvature<0 !--------------------------------------------------------------------- Use HFBTHO_utilities, Only: pr,ipr Use HFBTHO, Only: ierror_flag,ierror_info Implicit None Integer(ipr), Intent(In) :: N,iter,M Real(pr), Intent(In) :: alpha Real(pr), Intent(Out) :: si Character(1), Intent(Out) :: bbroyden Real(pr), Intent(InOut) :: vout(N),vin(N) Integer(ipr) :: i,j,iter_used,ipos,inext,info Integer(ipr), Allocatable, Save :: iwork(:) Real(pr), Allocatable, Save :: beta(:,:),work(:) Real(pr), Allocatable, Save :: df(:,:),dv(:,:),curv(:) Real(pr), Save :: w0 Real(pr) :: DDOT,DNRM2,normi,gamma,curvature,sf ! sf=-1.0_pr; Call DAXPY(N,sf,vin,1,vout,1) si=Maxval(Abs(vout)) ! Linear mixing If(M.Eq.0.Or.iter.Eq.0) Then bbroyden='L'; Call DAXPY(N,alpha,vout,1,vin,1) !If(iter.Eq.0) Write(6,*) ' Linear mixing (alpha) : ',alpha Return End If ! Broyden mixing iter_used=Min(iter-1,M) ipos=iter-1-((iter-2)/M)*M inext=iter-((iter-1)/M)*M If (iter.Eq.1) Then w0=0.010_pr If(Allocated(df)) Deallocate(curv,df,dv,beta,work,iwork) Allocate(curv(N),df(N,M),dv(N,M),beta(M,M),work(M),iwork(M)) Else df(:,ipos)=vout(:)-df(:,ipos); dv(:,ipos)=vin(:)-dv(:,ipos) Normi=1.0_pr/Sqrt((DNRM2(N,df(1,ipos),1))**2) Call DSCAL(N,Normi,df(1,ipos),1) Call DSCAL(N,Normi,dv(1,ipos),1) End If Do i=1,iter_used Do j=i+1,iter_used beta(i,j)=DDOT(N,df(1, j),1,df(1,i),1) End Do beta(i,i)=1.0_pr+w0*w0 End Do #if(SWITCH_ESSL==0) Call DSYTRF('U', iter_used, beta, M, iwork, work, M, info) #else Call DPOTRF('U', iter_used, beta, M, info) #endif If(info.Ne.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: In Broyden: info at DSYTRF ' Return End If #if(SWITCH_ESSL==0) Call DSYTRI('U', iter_used, beta, M, iwork, work, info) #else Call DPOTRI('U', iter_used, beta, M, info) #endif If(info.Ne.0) Then ierror_flag=ierror_flag+1 ierror_info(ierror_flag)='STOP: In Broyden: info at DSYTRI ' Return End If Do i=1,iter_used Do j=i+1,iter_used beta(j,i)=beta(i,j) End Do work(i)=DDOT(N,df(1,i),1,vout,1) End Do curv=alpha*vout Do i=1,iter_used gamma=0.0_pr Do j=1,iter_used gamma=gamma+beta(j,i)*work(j) End Do curv=curv-gamma*(dv(:,i)+alpha*df(:,i)) End Do Call DCOPY(N,vout,1,df(1,inext),1) Call DCOPY(N,vin,1,dv(1,inext),1) curvature=DDOT(N,vout,1,curv,1) If(curvature.Gt.-1.0_pr) Then bbroyden='B'; sf=+1.0_pr; Call DAXPY(N,sf,curv,1,vin,1) Else bbroyden='L'; sf=alpha*0.50_pr; Call DAXPY(N,sf,vout,1,vin,1) End If End Subroutine broyden_min !======================================================================= ! !======================================================================= Subroutine expect(lpr) !--------------------------------------------------------------------- ! calculates expectation values (xn is the particle number) ! at lpr=.true. also calculates PAV corrections !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Logical :: lpr Integer(ipr) :: i,it,ihli,iw Real(pr) :: ekt(3),xn(3),q4(3),def(3),bet2(3),het4(3),econst Real(pr) :: z,zz,rrr,p2,p3,p4,row,r212,r222,rc Real(pr) :: eso,ecodi,ecoex,rn,rp,rnp1,rnp2,rt,whl,tnt,tpt,tt Real(pr) :: dn,dp,dt,akn,akp,akn2,akp2,adn,adp,evol,esurf,ecoul Real(pr) :: etens,dd1n,dd1p,rt1,tt1,dt1,djn,djp,djt,djt1 Real(pr) :: RHO_0,RHO_1,TAU_0,TAU_1,DRHO_0,DRHO_1,DJ_0,DJ_1,J2_0,J2_1 Real(pr) :: SZFIN,SFIZN,SRFIN,SFIRN,SZFIP,SFIZP,SRFIP,SFIRP Real(pr) :: SZFI_0,SFIZ_0,SRFI_0,SFIR_0,SZFI_1,SFIZ_1,SRFI_1,SFIR_1 Real(pr) :: SNABLARN,SNABLAZN,SNABLARP,SNABLAZP Real(pr) :: SNABLAR_0,SNABLAZ_0,SNABLAR_1,SNABLAZ_1 Real(pr) :: xn1,xn2,rms1,rms2,q21,q22,q41,q42,EKIN_N,EKIN_P,ept1,ept2,del1,del2 Real(pr) :: rsa,rsa0,rsa0A,rps,rns,rsa1,rsa10,rsa12,rsa0An,rsa0As Real(pr) :: ESURF_rho_DELTA_rho,ESURF_NABLA_rho_NABLA_rho,ESO_rho_NABLA_J,ESO_NABLA_rho_J Real(pr) :: EVOL_rho_tau,EVOL_rho_rho,EExtra,E_HARTREE_DIR,tempE_Crho0,tempREARR Real(pr) :: E_EXT_FIELD Real(pr), Pointer :: EqpPo(:),VqpPo(:),UqpPo(:) Integer(ipr), Pointer :: KpwiPo(:),KqpPo(:) !------------------------------------------------ ! Part called during iterations (lpr=F) !------------------------------------------------ ! Call DENSIT If(ierror_flag.Ne.0) Return ! If (IDEBUG.Eq.1) Call get_CPU_time('expect',0) ! !------------------------------------------------ ! zero energy variables !------------------------------------------------ EKIN_N=zero; EKIN_P=zero; EVOL_rho_tau=zero; EVOL_rho_rho=zero; ESURF_rho_DELTA_rho=zero; ESURF_NABLA_rho_NABLA_rho=zero; ESO_rho_NABLA_J=zero; ESO_NABLA_rho_J=zero; E_HARTREE_DIR=zero ept1=zero; ept2=zero; del1=zero; del2=zero; ecodi=zero; ecoex=zero; etens=zero EExtra=zero ; E_EXT_FIELD = zero ; xn1=zero; xn2=zero; rms1=zero; rms2=zero q21=zero; q22=zero; q41=zero; q42=zero tempE_Crho0=zero; tempREARR=zero DEROT=zero; SQUJ=zero; CRAN=zero; ERIGHFB=zero !------------------------------------------------ ! zero optimization variables !------------------------------------------------ If(DO_FITT) Then efit_0=zero; efitV0=zero; dfitV0=zero efit_rhorho=zero; efit_rhorhoD=zero; efit_rhotau=zero; efit_rhoDrho=zero; efit_rhonablaJ=zero; efit_JJ=zero; End If !------------------------------------------------ ! Integration in coordinate space !------------------------------------------------ Do ihli=1,nghl whl=wdcor(ihli) !------------------------------------------------ ! np-representation !------------------------------------------------ rn=ro(ihli,1); rp=ro(ihli,2); rnp2=rn**2+rp**2; rnp1=rn-rp tnt=tau(ihli,1); tpt=tau(ihli,2); dn=dro(ihli,1); dp=dro(ihli,2); djn=dj(ihli,1); djp=dj(ihli,2); akn=aka(ihli,1); akp=aka(ihli,2) akn2=akn*akn; akp2=akp*akp adn=akn*rn; adp=akp*rp SFIZN=SFIZ(IHLI,1); SFIZP=SFIZ(IHLI,2); SFIRN=SFIR(IHLI,1); SFIRP=SFIR(IHLI,2); SZFIN=SZFI(IHLI,1); SZFIP=SZFI(IHLI,2); SRFIN=SRFI(IHLI,1); SRFIP=SRFI(IHLI,2); SNABLARN=NABLAR(IHLI,1); SNABLARP=NABLAR(IHLI,2); SNABLAZN=NABLAZ(IHLI,1); SNABLAZP=NABLAZ(IHLI,2); !------------------------------------------------ ! t-representation !------------------------------------------------ RHO_0=rn+rp; RHO_1=rn-rp; TAU_0=tnt+tpt; TAU_1=tnt-tpt; DRHO_0=dn+dp; DRHO_1=dn-dp; DJ_0=djn+djp; DJ_1=djn-djp; SFIZ_0=SFIZN+SFIZP; SFIZ_1=SFIZN-SFIZP; SFIR_0=SFIRN+SFIRP; SFIR_1=SFIRN-SFIRP; SZFI_0=SZFIN+SZFIP; SZFI_1=SZFIN-SZFIP; SRFI_0=SRFIN+SRFIP; SRFI_1=SRFIN-SRFIP; SNABLAR_0=SNABLARN+SNABLARP; SNABLAR_1=SNABLARN-SNABLARP; SNABLAZ_0=SNABLAZN+SNABLAZP; SNABLAZ_1=SNABLAZN-SNABLAZP; J2_0=SFIZ_0**2+SFIR_0**2+SZFI_0**2+SRFI_0**2 J2_1=SFIZ_1**2+SFIR_1**2+SZFI_1**2+SRFI_1**2 ! Call calculate_U_parameters(RHO_0,RHO_1,TAU_0,TAU_1,DRHO_0,DRHO_1, & (SNABLAR_0**2+SNABLAZ_0**2),(SNABLAR_1**2+SNABLAZ_1**2)) !------------------------------------------------ ! rms and deformations !------------------------------------------------ z=fh(ihli); zz=z*z; rrr=zz+fl(ihli)**2 p2=p32*zz-half*rrr; p3=p53*z*p2-p23*rrr*z; p4=p74*z*p3-p34*rrr*p2 row=whl*rn; xn1=xn1+row; rms1=rms1+row*rrr; q21=q21+row*p2; q41=q41+row*p4 row=whl*rp; xn2=xn2+row; rms2=rms2+row*rrr; q22=q22+row*p2; q42=q42+row*p4 !------------------------------------------------ ! PH energies !------------------------------------------------ EKIN_N=EKIN_N+hb0*(TAU_0+TAU_1)*HALF*whl*facECM ! kinetic, n EKIN_P=EKIN_P+hb0*(TAU_0-TAU_1)*HALF*whl*facECM ! kinetic, p EVOL_rho_tau=EVOL_rho_tau+(Urhotau(0,0)*RHO_0*TAU_0 & ! volume rho tau +Urhotau(1,0)*RHO_1*TAU_1+Urhotau(2,0)*RHO_0*TAU_1 & +Urhotau(3,0)*RHO_1*TAU_0 )*whl EVOL_rho_rho=EVOL_rho_rho+(Urhorho(0,0)*RHO_0**2 & ! volume density dependent +Urhorho(1,0)*RHO_1**2+(Urhorho(3,0)+Urhorho(2,0))*RHO_0*RHO_1)*whl ESURF_rho_DELTA_rho =ESURF_rho_DELTA_rho+(UrhoDrho(0,0)*RHO_0*DRHO_0 & ! surface: rho delta rho +UrhoDrho(1,0)*RHO_1*DRHO_1+UrhoDrho(2,0)*RHO_0*DRHO_1 & +UrhoDrho(3,0)*RHO_1*DRHO_0 )*whl ESURF_NABLA_rho_NABLA_rho=ESURF_NABLA_rho_NABLA_rho & ! surface: (nabla rho)**2 +(Unablarho(0,0)*(SNABLAR_0*SNABLAR_0+SNABLAZ_0*SNABLAZ_0) & +Unablarho(1,0)*(SNABLAR_1*SNABLAR_1+SNABLAZ_1*SNABLAZ_1) & +(Unablarho(3,0)+Unablarho(2,0))*(SNABLAR_0*SNABLAR_1+SNABLAZ_0*SNABLAZ_1) )*whl ESO_rho_NABLA_J=ESO_rho_NABLA_J+(UrhonablaJ(0,0)*RHO_0*DJ_0 & ! spin-orbit rho Nabla . J +UrhonablaJ(1,0)*RHO_1*DJ_1+UrhonablaJ(2,0)*RHO_0*DJ_1 & +UrhonablaJ(3,0)*RHO_1*DJ_0 )*whl ESO_NABLA_rho_J=ESO_NABLA_rho_J & +(UJnablarho(0,0)*(SNABLAR_0*(SFIZ_0-SZFI_0)-SNABLAZ_0*(SFIR_0-SRFI_0)) & ! spin-orbit J . Nabla rho +UJnablarho(1,0)*(SNABLAR_1*(SFIZ_1-SZFI_1)-SNABLAZ_1*(SFIR_1-SRFI_1)) & +UJnablarho(2,0)*(SNABLAR_1*(SFIZ_0-SZFI_0)-SNABLAZ_1*(SFIR_0-SRFI_0)) & +UJnablarho(3,0)*(SNABLAR_0*(SFIZ_1-SZFI_1)-SNABLAZ_0*(SFIR_1-SRFI_1)) )*whl ETENS=ETENS+(UJJ(0,0)*J2_0+UJJ(1,0)*J2_1 & ! tensor J^2 +(UJJ(3,0)+UJJ(2,0))*(SFIZ_0*SFIZ_1+SFIR_0*SFIR_1+SZFI_0*SZFI_1+SRFI_0*SRFI_1) )*whl EExtra=EExtra+(UEnonstdr(0)+UEnonstdr(1))*whl ! extra field if needed E_EXT_FIELD=E_EXT_FIELD + ( Vexternal(0,zero,fl(ihli),z)*RHO_0 & ! external field +Vexternal(1,zero,fl(ihli),z)*RHO_1 )*whl !------------------------------------------------ ! Coulomb & Hartree !------------------------------------------------ If (icou.Ge.1) ecodi=ecodi+half*cou(ihli)*rp*whl If (icou.Eq.2) ecoex=ecoex-CExPar*cex*rp**p43*whl E_HARTREE_DIR=E_HARTREE_DIR +half*vDHartree(ihli,1)*RHO_0*whl+half*vDHartree(ihli,2)*RHO_1*whl ! just for printing tempE_Crho0=tempE_Crho0+RHO_0**2*whl tempREARR=tempREARR+(Cdrho(0)*RHO_0**2+Cdrho(1)*RHO_1**2)*RHO_0**sigma*whl !------------------------------------------------ ! pairing energy and delta !------------------------------------------------ rsa0=(RHO_0/rho_c) dd1n=CpV0(0)*(ONE-rsa0*CpV1(0))*whl dd1p=CpV0(1)*(ONE-rsa0*CpV1(1))*whl ept1=ept1+dd1n*akn2; del1=del1-dd1n*adn ept2=ept2+dd1p*akp2; del2=del2-dd1p*adp !------------------------------------------------ ! optimization quantities !------------------------------------------------ If(DO_FITT) Then efitV0(0)=efitV0(0)+(ONE-rsa0*CpV1(0))*akn2*whl efitV0(1)=efitV0(1)+(ONE-rsa0*CpV1(1))*akp2*whl dfitV0(0)=dfitV0(0)-(ONE-rsa0*CpV1(0))*adn*whl dfitV0(1)=dfitV0(1)-(ONE-rsa0*CpV1(1))*adp*whl ! efit_rhotau(0)=efit_rhotau(0)+RHO_0*TAU_0*whl ! rho tau efit_rhotau(1)=efit_rhotau(1)+RHO_1*TAU_1*whl ! rho tau efit_rhorho(0)=efit_rhorho(0)+RHO_0**2*whl ! rho^2 efit_rhorho(1)=efit_rhorho(1)+RHO_1**2*whl ! rho^2 efit_rhorhoD(0)=efit_rhorhoD(0)+RHO_0**sigma*RHO_0**2*whl ! rho^2 efit_rhorhoD(1)=efit_rhorhoD(1)+RHO_0**sigma*RHO_1**2*whl ! rho^2 efit_rhoDrho(0)=efit_rhoDrho(0)+RHO_0*DRHO_0*whl ! rho Delta rho efit_rhoDrho(1)=efit_rhoDrho(1)+RHO_1*DRHO_1*whl ! rho Delta rho efit_rhonablaJ(0)=efit_rhonablaJ(0)+RHO_0*DJ_0*whl ! rho nabla J J efit_rhonablaJ(1)=efit_rhonablaJ(1)+RHO_1*DJ_1*whl ! rho nabla J J efit_JJ(0)=efit_JJ(0)+J2_0*whl ! J.J efit_JJ(1)=efit_JJ(1)+J2_1*whl ! J.J End If End Do !ihli !------------------------------------------------ ! after the integration !------------------------------------------------ xn(1)=xn1; xn(2)=xn2; xn(3)=xn1+xn2; rms(1)=rms1; rms(2)=rms2 q2(1)=q21; q2(2)=q22; q4(1)=q41; q4(2)=q42 ekt(1)=EKIN_N; ekt(2)=EKIN_P; ekt(3)=ekt(1)+ekt(2) ept(1)=ept1; ept(2)=ept2; ept(3)=ept(1)+ept(2) del(1)=del1/xn(1); del(2)=del2/xn(2); ! EVOL=EVOL_rho_tau+EVOL_rho_rho+E_HARTREE_DIR esurf=ESURF_rho_DELTA_rho+ESURF_NABLA_rho_NABLA_rho ESO=ESO_rho_NABLA_J+ESO_NABLA_rho_J ecoul=ecodi+ecoex etot=ekt(3)+evol+esurf+eso+ecoul+ept(3)+ETENS+EExtra+E_EXT_FIELD ehfb=etot entropy(3)=entropy(1)+entropy(2) !------------------------------------------------ ! rms and deformations !------------------------------------------------ Do it=itmin,itmax rms(it)=Sqrt(rms(it)/xn(it)) q2(it)=two*q2(it) !Qnp=<2r^2P_2(teta)>=<2z^2-x^2-y^2> q4(it)=ffdef4*q4(it) !Hn=8r^4P_4(teta)=8z^4-24z^2(x^2+y^2)+3(x^2+y^2)^2 def(it)=Sqrt(pi/5.0_pr)*q2(it)/(rms(it)**2*xn(it)) End Do r212=rms(1)**2; r222=rms(2)**2 rms(3)=Sqrt((xn(1)*r212+xn(2)*r222)/amas) q2(3)=q2(1)+q2(2) ! quadrupole moment q4(3)=q4(1)+q4(2) ! hexadecapole moment def(3)=Sqrt(pi/5.0_pr)*q2(3)/(rms(3)**2*amas) !deformation bet=def(3) !bet=ffdef6*q2(3)/(amas*r02) ! bet=Q2*Sqrt(5 Pi)/(3A x^2); x=r0 A^(1/3) !------------------------------------------------ ! Lipkin-Nogami energy !------------------------------------------------ If(kindhfb.Lt.0) Then Call tracesln If(ierror_flag.Ne.0) Return etot=etot+etr(3) End If !------------------------------------------------ ! optimization quantities !------------------------------------------------ If(DO_FITT) Then efV_0=0.0_pr If(kindhfb.Lt.0) Then efV_0(0)=ala2(1) efV_0(1)=ala2(2) End If dfitV0(0)=dfitV0(0)/xn(1) dfitV0(1)=dfitV0(1)/xn(2) efit_0=etot-efitV0(0)*CpV0(0)-efitV0(1)*CpV0(1) & -efit_rhotau(0)*Ctau(0)-efit_rhotau(1)*Ctau(1) & -efit_rhorho(0)*Crho(0)-efit_rhorho(1)*Crho(1) & -efit_rhorhoD(0)*Cdrho(0)-efit_rhorhoD(1)*Cdrho(1) & -efit_rhoDrho(0)*CrDr(0)-efit_rhoDrho(1)*CrDr(1) & -efit_rhonablaJ(0)*CrdJ(0)-efit_rhonablaJ(1)*CrdJ(1) & -efit_JJ(0)*CJ(0)-efit_JJ(1)*CJ(1) End If !------------------------------------------------ ! expectation values of multipole moments !------------------------------------------------ Call moments_computeValue() !------------------------------------------------ ! debug !------------------------------------------------ If(Print_Screen.And.IDEBUG.Gt.10) Then Write(*,'(4(a12,g13.6))') & ' Tn= ',ekt(1), ' Tp= ',ekt(2), & ' EPn= ',ept(1), ' EPp= ',ept(2), & ' EVOL= ',EVOL, ' Esurf= ',esurf, & ' NrNr= ',ESURF_NABLA_rho_NABLA_rho,' rDr= ',ESURF_rho_DELTA_rho, & ' Etens= ',ETENS, ' Eso= ',eso, & ' rNJ= ',ESO_rho_NABLA_J, ' NrJ= ',ESO_NABLA_rho_J, & ' ECd= ',ecodi, ' ECex= ',ecoex, & ' EHd= ',E_HARTREE_DIR, ' Ir0^2= ',tempE_Crho0, & ' Eextra= ',EExtra, ' Ext.Fl= ',E_EXT_FIELD, & ' Etot= ',etot If(DO_FITT) Then Write(*,'(4(a12,g13.6))') Write(*,'(4(a12,g13.6))') & ' efrr0= ',efit_rhorho(0), ' efrr1= ',efit_rhorho(1), & ' efrrD0= ',efit_rhorhoD(0), ' efrr1D= ',efit_rhorhoD(1), & ' efrt0= ',efit_rhotau(0), ' efrt1= ',efit_rhotau(1), & ' efrDr0= ',efit_rhoDrho(0), ' efrDr1= ',efit_rhoDrho(1), & ' efrDj0=',efit_rhonablaJ(0), ' efrDj1=',efit_rhonablaJ(1), & ' efjj0= ',efit_JJ(0), ' efjj1= ',efit_JJ(1), & ' efV0_0=',efitV0(0), ' efV0_1=',efitV0(1), & ' dfV0_0= ',dfitV0(0), ' dfV0_1= ',dfitV0(1), & ' efV0= ',efV_0(0), ' efV_1= ',efV_0(1), & ' ef0= ',efit_0, ' etot= ',etot End If End If !------------------------------------------------ ! Part called at the very end only (lpr=T) !------------------------------------------------ If (lpr) Then !------------------------------------------------ ! other definitions of deformations (ffdef6=Sqrt(5.0_pr*pi)/3.0_pr) !------------------------------------------------ bet2(1)=ffdef6*q2(1)/(xn(1)*r02) ! beta_n=Qn*Sqrt(5 Pi)/(3N x^2) bet2(2)=ffdef6*q2(2)/(xn(2)*r02) ! x=r0 A^(1/3) bet2(3)=ffdef6*q2(3)/(amas*r02) het4(1)=ffdef7*q4(1)/(xn(1)*r04) het4(2)=ffdef7*q4(2)/(xn(2)*r04) het4(3)=ffdef7*q4(3)/(amas*r04) rc=Sqrt(r222+0.640_pr) ! transitions to barn,barn^2,barn^4 Do i=1,3 q2(i)=q2(i)/100.0_pr; q4(i)=q4(i)/10000.0_pr End Do !------------------------------------------------ ! STORE to unprojected buffer 'eresu' !------------------------------------------------ ! ieresu=50 from module definitions ! ,'UEtot','Ubett','Ubetn','Ubetp',' UQt ',' UQn ',' UQp ' & eresu(1)=etot; eresu(2)=def(3); eresu(3)=def(1); eresu(4)=def(2); eresu(5)=q2(3); eresu(6)=q2(1); eresu(7)=q2(2); ! ,' Uln ',' Ulp ',' UpEn',' UpEp',' UpDn',' UpDp',' UAsn',' UAsp' & eresu(8)=alast(1); eresu(9)=alast(2); eresu(10)=ept(1); eresu(11)=ept(2); eresu(12)=del(1); eresu(13)=del(2); eresu(14)=ass(1); eresu(15)=ass(2); ! ,' Urt ',' Urn ',' Urp ',' Urc ',' Uht ',' Uhn ',' Uhp ' & eresu(16)=rms(3); eresu(17)=rms(1); eresu(18)=rms(2); eresu(19)=rc; eresu(20)=het4(3); eresu(21)=het4(1); eresu(22)=het4(2); ! ,' Uqht',' Uqhn',' Uqhp' & eresu(23)=q4(3); eresu(24)=q4(1); eresu(25)=q4(2); ! ,'UKINT','UKINN','UKINP',' USO ','UCDIR',' UCEX','UDisn','UDisp' & eresu(26)=ekt(3); eresu(27)=ekt(1); eresu(28)=ekt(2); eresu(29)=eso; eresu(30)=ecodi; eresu(31)=ecoex; eresu(32)=Dispersion(1); eresu(33)=Dispersion(2); ! ,'UV2Mn','UV2Mp' eresu(34)=v2min(1); eresu(35)=v2min(2); ! ,'UECMT','UECMN','UECMP' eresu(36)=ECMHFB(3); eresu(37)=ECMHFB(1); eresu(38)=ECMHFB(2); ! ,'UROTT','UROTN','UROTP' eresu(39)=DEROT(3); eresu(40)=DEROT(1); eresu(41)=DEROT(2); ! ,'USQUJT','USQUJN','USQUJP' eresu(42)=SQUJ(3); eresu(43)=SQUJ(1); eresu(44)=SQUJ(2); ! ,'UCRANT','UCRANN','UCRANP' eresu(45)=CRAN(3); eresu(46)=CRAN(1); eresu(47)=CRAN(2); ! ,'UERIGT','UERIGN','UERIGP' eresu(48)=ERIGHFB(3); eresu(49)=ERIGHFB(1); eresu(50)=ERIGHFB(2); ! ! nucleus with wrong assymptotic If(iasswrong(3).Ne.0) eresu(16)=-eresu(16) !------------------------------------------------ ! WRITE UNPROJECTED OUTPUT !------------------------------------------------ Do iw=lout,lfile Write(iw,*) Write(iw,'(a,9x,a)') ' NB! From expect (UNPROJECTED RESULTS)' Write(iw,*) If(iLST1.Ne.0) & Write(iw,'(a,3f15.6)') ' hfb decay const. ass ',ass Write(iw,'(a,5f15.6)') ' pairing: CpV0,CpV1,... ',CpV0,CpV1 Write(iw,'(a,a)') ' forces: ',skyrme If(keyblo(1).Ne.0) & Write(iw,'(a,i4,a,f10.3)') ' Blocked neutron block ', & bloblo(keyblo(1),1) If(keyblo(2).Ne.0) & Write(iw,'(a,i4,a,f10.3)') ' Blocked proton block ', & bloblo(keyblo(2),2) Write(iw,*) Write(iw,'(/,28x,a,8x,a,9x,a)') ' neutrons ','protons','total' Write(iw,'(a,6f15.6)') ' Requested part.numbs.',tz,Sum(tz) Write(iw,'(a,6f15.6)') ' UnPj(av) part.numbs .',xn Write(iw,'(a,3f15.6)') ' b0, bz, bp ..........',b0,bz,bp Write(iw,*) Write(iw,'(a,3f15.6)') ' lambda (ala) ........',ala Write(iw,'(a,3f15.6)') ' Lambda (alast) ......',alast Write(iw,'(a,3f15.6)') ' delta(n,p), pwi .....',del,pwi Write(iw,'(a,3f15.6)') ' pairing energy ......',ept If(kindhfb.Lt.0) Then Write(iw,'(a,3f15.6)') ' LN lambda_2 ... ala2 ',ala2 Write(iw,'(a,3f15.6)') ' LN energies .........',etr Write(iw,'(a,3f15.6)') ' delta(n,p)+ala2 .....',del+ala2 Write(iw,'(a,3f15.6)') ' Geff(n,p) ...........',Geff End If Write(iw,*) Write(iw,'(a,3f15.6)') ' rms-radius ..........',rms Write(iw,'(a,15x,2f15.6)') ' charge-radius, r0 ...',rc,r00 Write(iw,'(a,3f15.6)') ' deformation beta2....',def Write(iw,'(a,3f15.6)') ' dipole moment[fm] ...',(qmoment(1,it),it=1,3) Write(iw,'(a,3f15.6)') ' quadrupole moment[b] ',(qmoment(2,it),it=1,3) Write(iw,'(a,3f15.6)') ' octupole moment .....',(qmoment(3,it),it=1,3) Write(iw,'(a,3f15.6)') ' hexadecapole moment .',(qmoment(4,it),it=1,3) Write(iw,'(a,3f15.6)') ' q5 ..................',(qmoment(5,it),it=1,3) Write(iw,'(a,3f15.6)') ' q6 ..................',(qmoment(6,it),it=1,3) Write(iw,'(a,3f15.6)') ' q7 ..................',(qmoment(7,it),it=1,3) Write(iw,'(a,3f15.6)') ' q8 ..................',(qmoment(8,it),it=1,3) Write(iw,*) Write(iw,'(a,3f15.6)') ' kinetic energy ......',ekt Write(iw,'(a,30x,f15.6)') ' volume energy .......',evol Write(iw,'(a,30x,f15.6)') ' rho_tau .......',EVOL_rho_tau Write(iw,'(a,30x,f15.6)') ' rho_rho .......',EVOL_rho_rho Write(iw,'(a,30x,f15.6)') ' surface energy ......',esurf Write(iw,'(a,30x,f15.6)') ' rho_DELTA_rho ......',ESURF_rho_DELTA_rho Write(iw,'(a,30x,f15.6)') ' (NABLA_rho)^2 ......',ESURF_NABLA_rho_NABLA_rho Write(iw,'(a,30x,f15.6)') ' spin-orbit energy ...',eso Write(iw,'(a,30x,f15.6)') ' rho_NABLA_J ...',ESO_rho_NABLA_J Write(iw,'(a,30x,f15.6)') ' NABLA_rho_J ...',ESO_NABLA_rho_J Write(iw,'(a,30x,f15.6)') ' coulomb energy ......',ecodi+ecoex Write(iw,'(a,30x,f15.6)') ' direct ......',ecodi Write(iw,'(a,30x,f15.6)') ' exchange ....',ecoex Write(iw,'(a,30x,f15.6)') ' tensor energy .......',etens Write(iw,'(a,30x,f15.6)') ' direct Hartree E ...',E_HARTREE_DIR Write(iw,'(a,30x,f15.6)') ' Extra E .............',EEXTRA Write(iw,'(a,30x,f15.6)') ' External field E ....',E_EXT_FIELD Write(iw,'(a,3f15.6)') ' Entropy .............',entropy Write(iw,*) Write(iw,'(a,30x,f15.6)') ' tEnergy: ehfb (qp)...',ehfb If(kindhfb.Lt.0) Then Write(iw,'(a,30x,f15.6)') ' tEnergy: ehfb(qp)+LN ',etot End If Write(iw,*) Write(iw,'(a,6f15.6)') ' Calculated but not added corrections ' Write(iw,'(a,6f15.6)') '====================================' Write(iw,'(a,6f15.6)') ' cmc-diagonal part ...',ekt/hb0*hbzero-ekt Write(iw,'(a,6f15.6)') ' cmc-hfb .............',ECMHFB Write(iw,'(a,6f15.6)') ' cranking rot corr ...',DEROT Write(iw,*) Write(iw,'(a,6f15.6)') ' SQUJ ................',SQUJ Write(iw,'(a,6f15.6)') ' CRAN x 4 ............',4.0_pr*CRAN Write(iw,'(a,6f15.6)') ' Rigit Body ..........',ERIGHFB Write(iw,'(a,6f15.6)') End Do !------------------------------------------------ ! START corrected Lipkin-Nogami characteristics !------------------------------------------------ If(kindhfb.Lt.0) Then Call densitln !density LN corrections If(ierror_flag.Ne.0) Return Do it=itmin,itmax xn(it)=zero rms(it)=zero; q2(it)=zero; q4(it)=zero End Do ! Do ihli=1,nghl whl=wdcor(ihli) rn=ro(ihli,1); rp=ro(ihli,2); rnp2=rn**2+rp**2 ! rms and deformations z=fh(ihli); zz=z*z; rrr=zz+fl(ihli)**2 p2=p32*zz -half*rrr p3=p53*z*p2 -p23*rrr*z p4=p74*z*p3 -p34*rrr*p2 row=whl*rn xn(1)=xn(1)+row rms(1)=rms(1)+row*rrr q2(1)=q2(1)+row*p2 q4(1)=q4(1)+row*p4 row=whl*rp xn(2)=xn(2)+row rms(2)=rms(2)+row*rrr q2(2)=q2(2)+row*p2 q4(2)=q4(2)+row*p4 End Do !ihli !------------------------------------------------ ! rms and deformations !------------------------------------------------ Do it=itmin,itmax rms(it)=Sqrt(rms(it)/xn(it)) q2(it)=two*q2(it) !Qnp=<2r^2P_2(teta)>=<2z^2-x^2-y^2> q4(it)=ffdef4*q4(it) !Hn=<8r^4P_4(teta)>=<8z^4-24z^2(x^2+y^2)+3(x^2+y^2)^2> def(it)=Sqrt(pi/5.0_pr)*q2(it)/(rms(it)**2*xn(it)) End Do r212=rms(1)**2; r222=rms(2)**2 rms(3)=Sqrt((xn(1)*r212+xn(2)*r222)/amas) q2(3)=q2(1)+q2(2) ! quadrupole moment q4(3)=q4(1)+q4(2) ! hexadecapole moment def(3)=Sqrt(pi/5.0_pr)*q2(3)/(rms(3)**2*amas) !deformation ! other definitions of the same quantitsies bet2(1)=ffdef6*q2(1)/(xn(1)*r02) !beta_n=Qn*Sqrt(5Pi)/(3N x^2) bet2(2)=ffdef6*q2(2)/(xn(2)*r02) !x=r0=1.2A^(1/3) bet2(3)=ffdef6*q2(3)/(amas*r02) het4(1)=ffdef7*q4(1)/(xn(1)*r04) het4(2)=ffdef7*q4(2)/(xn(2)*r04) het4(3)=ffdef7*q4(3)/(amas*r04) xn(3)=xn(1)+xn(2) bet=def(3) rc=Sqrt(r222+0.640_pr) ! transitions to barn,barn^2,barn^4 Do i=1,3 q2(i)=q2(i)/100.0_pr; q4(i)=q4(i)/10000.0_pr End Do !------------------------------------------------ ! STORE to unprojected LN buffer 'eresl' !------------------------------------------------ ! ieresl=20 from module definitions ! ,' EHFBLN',' EHFB',' LNEt','LNbet','LNben','LNbep',' LNQt',' LNQn',' LNQp' & eresl(1)=etot; eresl(2)=etot-etr(3); eresl(3)=def(3); eresl(4)=def(1); eresl(5)=def(2) eresl(6)=q2(3); eresl(7)=q2(1); eresl(8)=q2(2); ! ,'LNpEn','LNpEp','LNpDn','LNpDp',' LNrt',' LNrn',' LNrC' & eresl(9)=ept(1); eresl(10)=ept(2); eresl(11)=del(1)+ala2(1); eresl(12)=del(2)+ala2(2); eresl(13)=rms(3); eresl(14)=rms(1); eresl(15)=rms(2); eresl(16)=rc; ! ,' LNam2n',' LNam2p',' LNe2n',' LNe2p' eresl(17)=ala2(1); eresl(18)=ala2(2); eresl(19)=etr(1); eresl(20)=etr(2) !------------------------------------------------ ! WRITE UNPROJECTED LN OUTPUT !------------------------------------------------ Do iw=lout,lfile Write(iw,'(a,3f15.6)') Write(iw,'(a,3f15.6)') ' With Lipkin-Nogami Corrections' Write(iw,'(a,3f15.6)') '================================' Write(iw,'(a,3f15.6)') ' rms-radius ..........',rms Write(iw,'(a,15x,2f15.6)') ' charge-radius, r0 ...',rc,r00 Write(iw,'(a,3f15.6)') ' deformation beta ....',def Write(iw,'(a,3f15.6)') ' quadrupole moment[b] ',q2 Write(iw,'(a,3f15.6)') ' hexadecapole moment .',q4 Write(iw,'(a,3f15.6)') '================================' Write(iw,'(a,3f15.6)') End Do End If !------------------------------------------------ ! WRITE all blocking candidates !------------------------------------------------ If(keyblo(3).Eq.0) Then Do iw=lout,lfile Write(iw,*) Do it=itmin,itmax If(it.Eq.1) Then EqpPo=>REqpN; VqpPo=>RVqpN; UqpPo=>RUqpN; KpwiPo=>KpwiN; KqpPo=>KqpN Else EqpPo=>REqpP; VqpPo=>RVqpP; UqpPo=>RUqpP; KpwiPo=>KpwiP; KqpPo=>KqpP End If ! Write(iw,*) ' ',' Blocking candidates are:' Write(iw,*) ' ',protn(it),' eqpmin=',eqpmin(it),' pwiblo=',pwiblo Do i=1,blomax(it) Write(iw,'(a,i4,a,i4,a,i4,2x,i4,3(a,1x,f12.8,1x),a)') ' num=',i, & ' block=',bloblo(i,it), & ' state=',blo123(i,it),blok1k2(i,it), & ' Eqp=',EqpPo(KqpPo(blok1k2(i,it))), & ' (1-2N)E=',(one-two*uk(blok1k2(i,it),it))*EqpPo(KqpPo(blok1k2(i,it))), & ' Ovlp=',vkmax(blok1k2(i,it),it), & tb(numax(blok1k2(i,it),it)) End Do Write(iw,*) End Do Write(iw,*) End Do End If ! !------------------------------------------------ ! PAV !------------------------------------------------ ! Projecting on different nucleus If(iproj.Ne.0) Then npr(1)=Int(npr1pj); npr(2)=Int(npr2pj) tz(1)=Real(npr(1),Kind=pr); tz(2)=Real(npr(2),Kind=pr) Call expectpj(.True.) End If End If ! If (IDEBUG.Eq.1) Call get_CPU_time('expect',1) ! End Subroutine expect !======================================================================= ! !=============================================================================================== Subroutine Constraint_or_not(inin_INI0,inin0,icstr0) Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr), Intent(in) :: inin_INI0 Integer(ipr), Intent(inout) :: inin0,icstr0 If(SUM(lambda_active).Gt.0) Then icstr0=1; inin0=inin_INI0 Else icstr0=0; inin0=inin_INI0 End If End Subroutine Constraint_or_not !=============================================================================================== ! !=============================================================================================== Subroutine moments_setUnits() Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: lambda Real(pr) :: sqr4pi !------------------------------------------------------ ! Defines standard units for multipole moments !------------------------------------------------------ If (.Not.Allocated(q_units)) Allocate(q_units(0:lambdaMax)); q_units = one sqr4pi=Sqrt(pp16*Atan(one)) q_units(0)=+sqr4pi q_units(1)=+sqr4pi/Sqrt(three) q_units(2)=+sqr4pi/Sqrt(five)*two Do lambda=0,lambdaMax q_units(lambda)=q_units(lambda) / ten**lambda End Do Return End Subroutine moments_setUnits !=============================================================================================== ! !=============================================================================================== Subroutine moments_computeValue() Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: lambda,ihli Real(pr), Dimension(0:8) :: Qval Real(pr) :: sqr4pi,z,z2,z3,z4,z5,z6,z7,z8,rrr,rrr4,rrr6 Real(pr) :: rown,rowp,whl,rn,rp !------------------------------------------------------ ! Expectation value of multipole moments !------------------------------------------------------ sqr4pi=one/Sqrt(pp16*Atan(one)) ! qmoment=zero; Qval=zero ! Do ihli=1,nghl ! whl=wdcor(ihli) rn=ro(ihli,1); rp=ro(ihli,2) rown=whl*rn; rowp=whl*rp; z=fh(ihli); rrr=fl(ihli)**2 ! Call moments_valueMesh(z,rrr,Qval) ! Do lambda=0,lambdaMax qmoment(lambda,1)=qmoment(lambda,1)+rown*Qval(lambda) qmoment(lambda,2)=qmoment(lambda,2)+rowp*Qval(lambda) End Do ! End Do ! Do lambda=0,lambdaMax qmoment(lambda,3)=qmoment(lambda,1)+qmoment(lambda,2) End Do Return End Subroutine moments_computeValue !=============================================================================================== ! !=============================================================================================== ! Subroutine moments_valueMesh(z,rrr,Qval) Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: lambda Real(pr), Dimension(0:8) :: Qval Real(pr) :: sqr4pi,z,z2,z3,z4,z5,z6,z7,z8,rrr,rrr4,rrr6 !------------------------------------------------------ ! Expectation value of multipole moments !------------------------------------------------------ ! sqr4pi=one/Sqrt(pp16*Atan(one)) ! z2=z*z; z3=z2*z; z4=z3*z; z5=z4*z; z6=z5*z; z7=z6*z; z8=z7*z rrr4=rrr*rrr; rrr6=rrr4*rrr ! Qval(0) = sqr4pi Qval(1) = Sqrt(three) *sqr4pi * z Qval(2) = Sqrt(five) *sqr4pi*half * (two*z2- rrr) Qval(3) = Sqrt(seven) *sqr4pi*half * (two*z3-three*z*rrr) Qval(4) = Sqrt(nine) *sqr4pi*p18 * (eight*z4-24.0_pr*z2*rrr + three *rrr4) Qval(5) = Sqrt(11.0_pr)*sqr4pi*p18 * (eight*z5- pp40*z3*rrr +pp15*z *rrr4) Qval(6) = Sqrt(13.0_pr)*sqr4pi/pp16 * (pp16*z6-120.0_pr*z4*rrr+ 90.0_pr*z2*rrr4-five *rrr6) Qval(7) = Sqrt(15.0_pr)*sqr4pi/pp16 * (pp16*z7-168.0_pr*z5*rrr+210.0_pr*z3*rrr4-35.0_pr*z*rrr6) Qval(8) = Sqrt(17.0_pr)*sqr4pi/128.0_pr * (128.0_pr*z8-1792.0_pr*z6*rrr +3360.0_pr*z4*rrr4 & -1120.0_pr*z2*rrr6+ 35.0_pr*rrr4*rrr4) ! If(Parity) Then Qval(1)=zero; Qval(3)=zero;Qval(5)=zero; Qval(7)=zero End If ! Do lambda=0,lambdaMax Qval(lambda)=Qval(lambda)*q_units(lambda) End Do ! Return End Subroutine moments_valueMesh !======================================================================= ! !======================================================================= Subroutine moments_computeField(lambda,ib) !--------------------------------------------------------------------- ! calculates fields in r-space form axially symmetric densities !--------------------------------------------------------------------- Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr) :: lambda Integer(ipr) :: i,ih,il,ib,nd,nd2,ihli,ihil,im,n1,n2 Integer(ipr) :: ja,jb,nsa,ssu,ssd Real(pr) :: qhla,vh,fiun1,fiun2,fidn1,fidn2,fiun12,fidn12 Real(pr), Allocatable :: Vmom(:) Real(pr), Dimension(0:8) :: Qval Real(pr) :: z,rrr ! Allocate(Vmom(1:nghl)) ! Qval=zero ! ! Compute moment lambda on integration mesh Do ihli = 1,nghl z=fh(ihli);rrr=fl(ihli)**2 Call moments_valueMesh(z,rrr,Qval) Vmom(ihli)=Qval(lambda) End Do !ihli ! ! Form matrix of the multipole constraint lambda in HO basis nd=id(ib); nd2=nd*nd; im=ia(ib) ! sum over gauss integration points Do ihil=1,nghl ! scan over basis states i=0 Do n1=1,nd ja=n1+im; fiun1 = QHLA_opt(ja,ihil) do n2=1,n1 i=i+1 jb=n2+im; fiun2 = QHLA_opt(jb,ihil) fiun12 = fiun1*fiun2 vh = two*fiun12 multMatElems(i)= multMatElems(i)+vh*Vmom(ihil) End Do !n2 End Do !n1 ! End Do !ihil Deallocate(Vmom) ! Return End Subroutine moments_computeField !=============================================================================================== ! !=============================================================================================== Subroutine getLagrange(ite) Use HFBTHO_utilities Use HFBTHO Implicit None Character(Len=1) :: trans Integer(ipr) :: ite,icons,lambda,icount,it,i,j,l,ierror Integer(ipr) :: ib,nd,nd2,nhfb,i0,m,k1,k2,n1,n2,nd1,k,kk,ll Integer(ipr) :: i_uvN,i_uvP,incx,incy Integer(ipr), allocatable :: ipivot(:),iftN(:),iftP(:) Real(pr) :: minu,hla,t_term,temp_k,temp_l,result,brakev,epsilo Real(pr), allocatable :: EqpN(:),EqpP(:) Real(pr), allocatable :: vecold(:),qmultt(:),veclam(:),veccns(:) Real(pr), allocatable :: cnsorg(:,:),cnsmat(:,:),cnsvec(:) Real(pr), allocatable :: fn12pl(:,:,:),fp12pl(:,:,:) Real(pr), allocatable :: fn11pl(:,:,:),fp11pl(:,:,:),fn11mi(:,:,:),fp11mi(:,:,:) Real(pr), allocatable :: doubln(:,:),doublp(:,:),dsum_n(:,:),dsum_p(:,:) Real(pr), allocatable :: workcn(:),dblmul(:,:),Umatr(:,:),Vmatr(:,:) !--------------------------------------------------------------------- ! This routine updates the lagrange multipliers of the multi- ! dimensional linear constraints based on the variation of the ! generalized density matrix and the rpa matrix at the cranking ! approximation. ! ! references: (1) phys. rev. c21, 1568 (1980) ! (2) phys. rev. c80, 054313 (2009) !--------------------------------------------------------------------- ! minu=-one epsilo=1.E-14 ! ! initializing the multipole moment template array Allocate(qmultt(0:lambdaMax));qmultt=zero Do lambda=0,lambdaMax qmultt(lambda)=qmoment(lambda,3) End Do ! ! constructing the vector of the deviations of the current constraint ! from the requested values ! Allocate(vecold(1:numberCons));vecold=zero Allocate(cnsvec(1:numberCons));cnsvec=zero Allocate(veclam(1:numberCons));veclam=zero ! Do icons=1,numberCons lambda=multLambda(icons) cnsvec(icons)=multRequested(lambda)-qmultt(lambda) If (nbroyden.lt.1) Then vecold(icons)=multLag(lambda) Else vecold(icons)=brin(nhhdim4+lambda) End If veclam(icons)=vecold(icons) End Do ! ! proceeding to determine the matrix of the constraint operators ! in the q.p. basis ! loop over the K blocks Allocate(cnsmat(numberCons,numberCons));cnsmat=zero Allocate(cnsorg(numberCons,numberCons));cnsorg=zero ! i_uvN=0 ! new index referring to all q.p. vectors i_uvP=0 ! new index referring to all q.p. vectors ! Do ib = 1,nb ! !------------------------------------------------------ ! matrix of the constraint in q.p. basis !------------------------------------------------------ ! !------------------------------------------------------ ! neutron sector !------------------------------------------------------ ! it=1 ! nd=id(ib); nd2=nd*nd; nhfb=nd+nd; i0=ia(ib); m=ib+(it-1)*nbx ! If(kd(ib,it).Gt.0) Then Allocate(doubln(nd,kd(ib,it))); doubln=zero Allocate(fn12pl(kd(ib,it),kd(ib,it),numberCons)); fn12pl=zero Allocate(Umatr(nd,kd(ib,it))); Umatr=zero Allocate(Vmatr(nd,kd(ib,it))); Vmatr=zero Allocate(EqpN(kd(ib,it))); EqpN=zero Allocate(ifTN(kd(ib,it))); ifTN=1 ! temperature If(switch_on_temperature) Then Allocate(fn11pl(kd(ib,it),kd(ib,it),numberCons)); fn11pl=zero End If ! ! U and V for this block (v. 101) Do k=1,kd(ib,it) ifTN(k)=ka(ib,it)+k; kk=KqpN(ka(ib,it)+k); EqpN(k)=REqpN(kk) Do n1=1,nd i_uvN=i_uvN+1 Vmatr(n1,k)=RVqpN(i_uvN) Umatr(n1,k)=RUqpN(i_uvN) End Do End Do ! Do icons=1,numberCons ! Allocate(multMatElems(1:nd2)); multMatElems=zero ! lambda=multLambda(icons); Call moments_computeField(lambda,ib) ! ! matrix of the constraints in HO basis (size nd x nd) Allocate(dblmul(nd,nd));dblmul=zero j=0 Do n1=1,nd Do n2=1,n1 j=j+1;hla=multMatElems(j) dblmul(n1,n2)=hla;dblmul(n2,n1)=hla End Do End Do ! ! matrix of the constraint operator in the qp basis. due to ! the q.p. cut-off the actual size of the q.p. basis is not ! the same as the s.p. (ho) basis, and it is not the same ! for protons and neutrons. the formulas implemented below ! differ from the 2 references for 3 reasons: ! - different phase convention for the bogoliubov matrix ! - block structure of the bogoliubov matrix in hfodd ! - storage in a() and b() arrays correspond to complex ! conjugate of the actual matrices ! ! second term: v^{+} f^{*} u^{*} = v^{T} f u Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Umatr,nd,zero,doubln,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Vmatr,nd,doubln,nd,zero,fn12pl(1,1,icons),kd(ib,it)) ! ! first term: u^{+} f v^{*} = u^{T} f v Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Vmatr,nd,zero,doubln,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Umatr,nd,doubln,nd,minu,fn12pl(1,1,icons),kd(ib,it)) ! ! temperature - computing \tilde{f}^{11} If(switch_on_temperature) Then ! ! second term: v^{+} f^{*} v = v^{T} f v Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Vmatr,nd,zero,doubln,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Vmatr,nd,doubln,nd,zero,fn11pl(1,1,icons),kd(ib,it)) ! first term: u^{+} f u = u^{T} f u Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Umatr,nd,zero,doubln,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Umatr,nd,doubln,nd,minu,fn11pl(1,1,icons),kd(ib,it)) ! End If ! Deallocate(multMatElems) Deallocate(dblmul) ! End Do ! end icons (neutrons) ! Deallocate(doubln,Umatr,Vmatr) End If ! !------------------------------------------------------ ! Proton sector !------------------------------------------------------ ! it=2 ! nd=id(ib); nd2=nd*nd; nhfb=nd+nd; i0=ia(ib); m=ib+(it-1)*nbx ! If(kd(ib,it).Gt.0) Then Allocate(doublp(nd,kd(ib,it))); doublp=zero Allocate(fp12pl(kd(ib,it),kd(ib,it),numberCons)); fp12pl=zero Allocate(Umatr(nd,kd(ib,it))); Umatr=zero Allocate(Vmatr(nd,kd(ib,it))); Vmatr=zero Allocate(EqpP(kd(ib,it))); EqpP=zero Allocate(ifTP(kd(ib,it))); ifTP=1 ! temperature If(switch_on_temperature) Then Allocate(fp11pl(kd(ib,it),kd(ib,it),numberCons)); fp11pl=zero End If ! ! U and V for this block Do k=1,kd(ib,it) ifTP(k)=ka(ib,it)+k; kk=KqpP(ka(ib,it)+k); EqpP(k)=REqpP(kk) Do n1=1,nd i_uvP=i_uvP+1 Vmatr(n1,k)=RVqpP(i_uvP) Umatr(n1,k)=RUqpP(i_uvP) End Do End Do ! Do icons=1,numberCons ! Allocate(multMatElems(1:nd2)); multMatElems=zero ! lambda=multLambda(icons); Call moments_computeField(lambda,ib) ! ! matrix of the constraints in HO basis (size nd x nd) Allocate(dblmul(nd,nd));dblmul=zero j=0 Do n1=1,nd Do n2=1,n1 j=j+1;hla=multMatElems(j) dblmul(n1,n2)=hla;dblmul(n2,n1)=hla End Do End Do ! ! matrix of the constraint operator in the qp basis. due to ! the q.p. cut-off the actual size of the q.p. basis is not ! the same as the s.p. (ho) basis, and it is not the same ! for protons and neutrons. the formulas implemented below ! differ from the 2 references for 3 reasons: ! - different phase convention for the bogoliubov matrix ! - block structure of the bogoliubov matrix in hfodd ! - storage in a() and b() arrays correspond to complex ! conjugate of the actual matrices ! ! second term: v^{+} f^{*} u^{*} = v^{t} f u Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Umatr,nd,zero,doublp,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Vmatr,nd,doublp,nd,zero,fp12pl(1,1,icons),kd(ib,it)) ! ! first term: u^{+} f v^{*} = u^{t} f v Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Vmatr,nd,zero,doublp,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Umatr,nd,doublp,nd,minu,fp12pl(1,1,icons),kd(ib,it)) ! ! temperature - computing \tilde{f}^{11} If(switch_on_temperature) Then ! ! second term: v f^{*} v = v^{T} f v Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Vmatr,nd,zero,doublp,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Vmatr,nd,doublp,nd,zero,fp11pl(1,1,icons),kd(ib,it)) ! first term: u f u = u^{T} f u Call dgemm('n','n',nd,kd(ib,it),nd,one,dblmul,nd,Umatr,nd,zero,doublp,nd) Call dgemm('t','n',kd(ib,it),kd(ib,it),nd,one,Umatr,nd,doublp,nd,minu,fp11pl(1,1,icons),kd(ib,it)) ! End If ! Deallocate(dblmul) Deallocate(multMatElems) ! End Do ! end icons (protons) ! Deallocate(doublp,Umatr,Vmatr) End If ! !------------------------------------------------------ ! constraint correlation matrix !------------------------------------------------------ ! !------------------------------------------------------ ! neutron sector !------------------------------------------------------ ! it=1 ! If(kd(ib,it).Gt.0) Then Allocate(doubln(kd(ib,it),kd(ib,it))); doubln=zero Allocate(dsum_n(kd(ib,it),kd(ib,it))); dsum_n=zero ! Do i=1,numberCons Do j=1,numberCons ! ! temperature If((.Not.switch_on_temperature)) Then ! Do l=1,kd(ib,it) Do k=1,kd(ib,it) If(Abs(EqpN(k)+EqpN(l)).Gt.Epsilo) Then doubln(k,l)=fn12pl(k,l,i)/(EqpN(k)+EqpN(l)) Else doubln(k,l)=zero End If End Do End do ! Call dgemm('t','n',kd(ib,it),kd(ib,it),kd(ib,it),one,fn12pl(1,1,j),kd(ib,it),& doubln,kd(ib,it),zero,dsum_n,kd(ib,it)) Else ! ! term corresponding to f^12 Do l=1,kd(ib,it) Do k=1,kd(ib,it) kk=iftN(k);ll=iftN(l) temp_k=fn_T(kk) temp_l=fn_T(ll) If(Abs(EqpN(k)+EqpN(l)).Gt.Epsilo) Then doubln(k,l)=fn12pl(k,l,i)*(one+temp_k+temp_l)/(EqpN(k)+EqpN(l)) Else doubln(k,l)=zero End If End Do End Do ! Call dgemm('t','n',kd(ib,it),kd(ib,it),kd(ib,it),one,fn12pl(1,1,j),kd(ib,it),& doubln,kd(ib,it),zero,dsum_n,kd(ib,it)) ! ! first term: positive simplex Do l=1,kd(ib,it) Do k=1,kd(ib,it) kk=iftN(k);ll=iftN(l) temp_k=fn_T(kk) temp_l=fn_T(ll) If(k.ne.l.And.(Abs(EqpN(k)-EqpN(l)).Gt.Epsilo)) Then t_term=-(temp_k-temp_l)/(EqpN(k)-EqpN(l)) Else t_term=-temp_k*(temp_k-one)/temper End If doubln(k,l)=half*t_term*fn11pl(k,l,i) End Do End Do ! Call dgemm('t','n',kd(ib,it),kd(ib,it),kd(ib,it),one,fn11pl(1,1,j),kd(ib,it),& doubln,kd(ib,it),one,dsum_n,kd(ib,it)) ! End If ! ! taking the trace of the resulting matrix ! result=zero Do l=1,kd(ib,it) result=result+dsum_n(l,l) End Do ! cnsmat(i,j)=cnsmat(i,j)+0.5*result ! End Do ! end of loop over j constraint End Do ! end of loop over i constraint ! Deallocate(doubln,dsum_n,fn12pl,EqpN,ifTN) If(switch_on_temperature) Deallocate(fn11pl) End If ! !------------------------------------------------------ ! proton sector !------------------------------------------------------ ! it=2 ! If(kd(ib,it).Gt.0) Then Allocate(doublp(kd(ib,it),kd(ib,it))); doublp=zero Allocate(dsum_p(kd(ib,it),kd(ib,it))); dsum_p=zero ! Do i=1,numberCons Do j=1,numberCons ! ! temperature If((.Not.switch_on_temperature)) Then ! Do l=1,kd(ib,it) Do k=1,kd(ib,it) If(Abs(EqpP(k)+EqpP(l)).Gt.Epsilo) Then doublp(k,l)=fp12pl(k,l,i)/(EqpP(k)+EqpP(l)) Else doublp(k,l)=zero End If End Do End do ! Call dgemm('t','n',kd(ib,it),kd(ib,it),kd(ib,it),one,fp12pl(1,1,j),kd(ib,it),& doublp,kd(ib,it),zero,dsum_p,kd(ib,it)) Else ! ! term corresponding to f^12 Do l=1,kd(ib,it) Do k=1,kd(ib,it) kk=iftP(k);ll=iftP(l) temp_k=fp_T(kk) temp_l=fp_T(ll) If(Abs(EqpP(k)+EqpP(l)).Gt.Epsilo) Then doublp(k,l)=fp12pl(k,l,i)*(one+temp_k+temp_l)/(EqpP(k)+EqpP(l)) Else doublp(k,l)=zero End If End Do End Do ! Call dgemm('t','n',kd(ib,it),kd(ib,it),kd(ib,it),one,fp12pl(1,1,j),kd(ib,it),& doublp,kd(ib,it),zero,dsum_p,kd(ib,it)) ! ! first term: positive simplex Do l=1,kd(ib,it) Do k=1,kd(ib,it) kk=iftP(k);ll=iftP(l) temp_k=fp_T(kk) temp_l=fp_T(ll) If(k.ne.l.And.(Abs(EqpP(k)-EqpP(l)).Gt.Epsilo)) Then t_term=-(temp_k-temp_l)/(EqpP(k)-EqpP(l)) Else t_term=-temp_k*(temp_k-one)/temper End If doublp(k,l)=half*t_term*fp11pl(k,l,i) End Do End Do ! Call dgemm('t','n',kd(ib,it),kd(ib,it),kd(ib,it),one,fp11pl(1,1,j),kd(ib,it),& doublp,kd(ib,it),one,dsum_p,kd(ib,it)) ! End If ! ! taking the trace of the resulting matrix ! result=zero Do l=1,kd(ib,it) result=result+dsum_p(l,l) End Do ! cnsmat(i,j)=cnsmat(i,j)+0.5*result ! End Do ! end of loop over j constraint End Do ! end of loop over i constraint ! Deallocate(doublp,dsum_p,fp12pl,EqpP,ifTP) If(switch_on_temperature) Deallocate(fp11pl) End If ! End Do ! end of loop over blocks ib ! ! computing the inverse of the correlation matrix cnsorg=cnsmat ! ierror=0 Allocate(ipivot(numberCons)) Call dgetrf(numberCons,numberCons,cnsmat,numberCons,ipivot,ierror) ! ierror=0 Allocate(workcn(numberCons)) Call dgetri(numberCons,cnsmat,numberCons,ipivot,workcn,numberCons,ierror) Deallocate(ipivot) ! ! constructing the vector of variations of the linear constraints trans='N'; incx=1; incy=1 Call dgemv(trans,numberCons,numberCons,one,cnsmat,numberCons,cnsvec,incx,zero,workcn,incy) ! ! updating the linear constraint vector (mixing has to be done simultaneously). If (ite.Eq.0) Then brakev=zero Else brakev=xmix End If ! Allocate(veccns(numberCons)) Do i=1,numberCons veccns(i)=veclam(i)+workcn(i) lambda=multLambda(i) If(nbroyden.lt.1) Then multLag(lambda)=brakev*vecold(i)+(1.0-brakev)*veccns(i) Else multLag(lambda)=veccns(i) brout(nhhdim4+lambda)=multLag(lambda) End If End Do ! Deallocate(veccns,vecold,workcn) Deallocate(cnsmat,cnsorg) Deallocate(qmultt,cnsvec,veclam) ! Return End Subroutine getLagrange !=============================================================================================== ! !=============================================================================================== Subroutine requested_blocked_level(ib,it) !------------------------------------------------------ ! Search for the requested state to block !------------------------------------------------------ Use HFBTHO_utilities Use HFBTHO Implicit None Integer(ipr), Intent(in) :: ib,it Integer(ipr) :: nd,im,k,ndk,na2,nad2,iqn,k0,LAPLUS,OMEGA,n1,n2,n3 Real(pr) :: s1,s2,UUk,VVk k0=0 If(nkblo(it,2).Eq.0) Return If(Parity) Then LAPLUS=(ib+1)/2 !Yesp Else LAPLUS=ib !Nop End If OMEGA=2*LAPLUS-1 If(nkblo(it,1).Ne.OMEGA) Return nd=ID(ib); im=ia(ib); Do k=1,nd ndk=k+nd; s1=zero Do na2=1,nd nad2=na2+nd UUk=allhfb(ib)%arr(na2,ndk) VVk=allhfb(ib)%arr(nad2,ndk) s2=Max(s1,Abs(UUk),Abs(VVk)) If(s2.Gt.s1) Then s1=s2 iqn=na2+im ! the position in [123] numbering End If End Do ! quantum numbers: Omega,P[n1,n2,n3]=>OMEGA,tpar(npar(iqn))[nz(iqn)+2*nr(iqn)+nl(iqn),nz(iqn),nl(iqn)] If(nkblo(it,2).Ne.tpar(npar(iqn))) Cycle n3=nl(iqn); If(nkblo(it,5).Ne.n3) Cycle n2=nz(iqn); If(nkblo(it,4).Ne.n2) Cycle n1=n2+2*nr(iqn)+n3; If(nkblo(it,3).Ne.n1) Cycle k0=iqn keyblo(it)=1 bloblo(keyblo(it),it)=ib blo123(keyblo(it),it)=k Exit End Do End Subroutine requested_blocked_level !=================================================================================================================================== !#END HFBTHO_SOLVER !=================================================================================================================================== End Module hfodd_hfbtho !=================================================================================================================================== !#END hfodd_hfbtho !===================================================================================================================================