diff --git a/src/solvation/hnd_cosmo_lib.F b/src/solvation/hnd_cosmo_lib.F index 0e6a49de34..93fafc3a50 100644 --- a/src/solvation/hnd_cosmo_lib.F +++ b/src/solvation/hnd_cosmo_lib.F @@ -92,26 +92,32 @@ c if(.not.ma_push_get(mt_dbl,need,'mem init:cosmo:hnd_cosset:1', c & i_init,init)) c & call errquit('hnd_cosset, malloc of init failed',911,MA_ERR) c - stat = .true. - stat = stat.and.ma_push_get(mt_dbl,3*nat,"xyzatm",l_i10,i10) - stat = stat.and.ma_push_get(mt_dbl, nat,"ratm",l_i20,i20) - stat = stat.and.ma_push_get(mt_int, nat,"nspa",l_i30,i30) - stat = stat.and.ma_push_get(mt_int, nat,"nppa",l_i40,i40) - stat = stat.and.ma_push_get(mt_int,3*mxface,"ijkfac",l_i50,i50) - stat = stat.and.ma_push_get(mt_dbl,3*mxface,"xyzseg",l_i60,i60) - stat = stat.and.ma_push_get(mt_int, mxface,"ijkseg",l_i70,i70) - stat = stat.and.ma_push_get(mt_log, mxface*nat,"insseg", - & l_i80,i80) - stat = stat.and.ma_push_get(mt_dbl,3*mxface*nat,"xyzspa", - & l_i90,i90) - stat = stat.and.ma_push_get(mt_int, mxface*nat,"ijkspa", - & l_i100,i100) - stat = stat.and.ma_push_get(mt_int, mxface*nat,"numpps", - & l_i110,i110) - stat = stat.and.ma_push_get(mt_dbl,3*mxapex ,"apex", - & l_i120,i120) - stat = stat.and.ma_push_get(mt_dbl, mxface*nat,"xyzff", - & l_i130,i130) + if(.not.ma_push_get(mt_dbl,3*nat,"xyzatm",l_i10,i10)) + c call errquit('hndcosset: not enuf mem',0,MA_ERR) + if(.not.ma_push_get(mt_dbl, nat,"ratm",l_i20,i20)) + c call errquit('hndcosset: not enuf mem',1,MA_ERR) + if(.not.ma_push_get(mt_int, nat,"nspa",l_i30,i30)) + c call errquit('hndcosset: not enuf mem',2,MA_ERR) + if(.not.ma_push_get(mt_int, nat,"nppa",l_i40,i40)) + c call errquit('hndcosset: not enuf mem',3,MA_ERR) + if(.not.ma_push_get(mt_int,3*mxface,"ijkfac",l_i50,i50)) + c call errquit('hndcosset: not enuf mem',4,MA_ERR) + if(.not.ma_push_get(mt_dbl,3*mxface,"xyzseg",l_i60,i60)) + c call errquit('hndcosset: not enuf mem',5,MA_ERR) + if(.not.ma_push_get(mt_int, mxface,"ijkseg",l_i70,i70)) + c call errquit('hndcosset: not enuf mem',6,MA_ERR) + if(.not.ma_push_get(mt_log, mxface*nat,"insseg",l_i80,i80)) + c call errquit('hndcosset: not enuf mem',7,MA_ERR) + if(.not.ma_push_get(mt_dbl,3*mxface*nat,"xyzspa",l_i90,i90)) + c call errquit('hndcosset: not enuf mem',8,MA_ERR) + if(.not.ma_push_get(mt_int, mxface*nat,"ijkspa",l_i100,i100)) + c call errquit('hndcosset: not enuf mem',9,MA_ERR) + if(.not.ma_push_get(mt_int, mxface*nat,"numpps",l_i110,i110)) + c call errquit('hndcosset: not enuf mem',10,MA_ERR) + if(.not.ma_push_get(mt_dbl,3*mxapex ,"apex",l_i120,i120)) + c call errquit('hndcosset: not enuf mem',11,MA_ERR) + if(.not.ma_push_get(mt_dbl, mxface*nat,"xyzff",l_i130,i130)) + c call errquit('hndcosset: not enuf mem',12,MA_ERR) c i10 =init ! xyzatm(3,nat) c i20 =i10 +3*nat ! ratm( nat) c i30 =i20 + nat ! nspa( nat) @@ -129,9 +135,10 @@ c ----- get -cosmo- surface ----- c call hnd_cossrf(nat,c,radius,nat,mxface,mxapex, 1 dbl_mb(i10),dbl_mb(i20),int_mb(i30),int_mb(i40), - 2 int_mb(i50),dbl_mb(i60),int_mb(i70), - 3 log_mb(i80),dbl_mb(i90),int_mb(i100),int_mb(i110), + 2 int_mb(i50),dbl_mb(i60),int_mb(i70),log_mb(i80), + 3 dbl_mb(i90),int_mb(i100),int_mb(i110), 4 dbl_mb(i120),dbl_mb(i130),rtdb) + c c ----- release memory block ----- c @@ -157,7 +164,7 @@ c #include "global.fh" #include "stdio.fh" #include "cosmoP.fh" -c +#include "mafdecls.fh" integer rtdb, nat integer mxatm integer mxfac @@ -261,6 +268,7 @@ c c c ----- create -solvent accessible surface- of the molecule ----- c + call hnd_cossas(nat,xyzatm,ratm,mxatm, 1 nspa,nppa,xyzspa,ijkspa, 2 nseg,nfac,xyzseg,ijkseg,insseg, @@ -366,6 +374,7 @@ C> #include "stdio.fh" #include "bq.fh" #include "prop.fh" +cnew #include "cosmoP.fh" c integer rtdb !< [Input] The RTDB handle @@ -410,7 +419,6 @@ c integer numpps( mxface,mxatom) double precision xyzff( mxface,mxatom) double precision zero, one - data zero /0.0d+00/ data one /1.0d+00/ integer l_efcc, k_efcc, l_efcs, k_efcs, l_efcz, k_efcz integer l_efclb, k_efclb, k_efciat, l_efciat @@ -464,7 +472,7 @@ c do i=1,mxface ijkspa(i,iat)=0 numpps(i,iat)=0 - xyzff(i,iat)=zero + xyzff(i,iat)=0d0 enddo enddo c @@ -473,7 +481,7 @@ c belongs to the -sas- or is inside the molecule. c do iat=1,nat c - if(ratm(iat).ne.zero) then + if(ratm(iat).ne.0d0) then do iseg=1,nseg ijkspa(iseg,iat)=ijkseg(iseg) xyzff(iseg,iat)=one @@ -515,7 +523,7 @@ c enddo endif else if (do_cosmo_model.eq.DO_COSMO_YK) then - if((jat.ne.iat).and.(ratm(jat).ne.zero) + if((jat.ne.iat).and.(ratm(jat).ne.0d0) 1 .and.(dij.lt.(ratm(iat)+rout(jat)))) then do iseg=1,nseg dum=dist(xyzspa(1,iseg,iat), @@ -615,7 +623,7 @@ c and generate memory to store them c nefc = 0 do iat=1,nat - if(ratm(iat).ne.zero) then + if(ratm(iat).ne.0d0) then do iseg=1,nseg if(.not.insseg(iseg,iat)) nefc = nefc+1 enddo @@ -639,11 +647,11 @@ c ----- save coordinates of surface points ----- c save segment surfaces c save segment to atom mapping c - srfmol=zero - volmol=zero + srfmol=0d0 + volmol=0d0 ief =0 do iat=1,nat - if(ratm(iat).ne.zero) then + if(ratm(iat).ne.0d0) then if (do_cosmo_model.eq.DO_COSMO_KS) then ratm_real=ratm(iat)-rsolv/bohr else if (do_cosmo_model.eq.DO_COSMO_YK) then @@ -720,7 +728,7 @@ c endif c do ief=1,nefc - dbl_mb(k_efcz+ief-1)=zero + dbl_mb(k_efcz+ief-1)=0d0 enddo do ief=1,nefc byte_mb(k_efclb+(ief-1)*8)=' ' @@ -877,6 +885,8 @@ C> implicit double precision (a-h,o-z) #include "global.fh" #include "stdio.fh" +cnew +#include "cosmoP.fh" c c ----- starting from -icosahedron- ----- c