--- nwnbo.F 2008-05-20 11:06:18.120686000 -0700 +++ /home/bert/nwchem-5.1/src/nbo/nwnbo.F 2008-05-20 11:07:20.857043000 -0700 @@ -602,7 +602,7 @@ C C IF NBOOPT(1).EQ.-2, THEN NO NBO ANALYSIS WAS REQUESTED: C - IF(NBOOPT(1).EQ.-2) RETURN + IF(NBOOPT(1).EQ.-2) GOTO 211 C C SET DEFAULT OPTIONS: C @@ -640,7 +640,7 @@ C C FETCH ATOMS, BASIS, AND WAVE FUNCTION INFORMATION: C - CALL FEAOIN(CORE,CORE,MEMORY,NBOOPT) + 211 CALL FEAOIN(CORE,CORE,MEMORY,NBOOPT) IF(NBAS.GT.MAXBAS) THEN ERROR = .TRUE. WRITE(LFNPR,930) NBAS,MAXBAS @@ -651,6 +651,7 @@ RETURN END IF IF(COMPLX) RETURN + IF(NBOOPT(1).EQ.-2) GOTO 311 C C WRITE THE JOB TITLE TO THE OUTPUT FILE: C @@ -754,7 +755,8 @@ C C CHECKPOINT TRANSFORMATIONS: C - IF(JPRINT(63).NE.0) CALL CHKNBO(CORE) +311 IF(JPRINT(63).NE.0) CALL CHKNBO(CORE) + IF(NBOOPT(1).EQ.-2) RETURN C C CLOSE THE DAF AND DELETE IT ACCORDING TO NBOOPT(7,10): C @@ -41914,7 +41916,7 @@ C N W C N B O C C -C NWChem 3.2 version of the NBO program +C NWChem 5.1 version of the NBO program C C C Driver routines: @@ -41951,31 +41953,29 @@ C Save rtdb state: C if(.not.task_save_state(rtdb, 'nbo')) - + call errquit('nbo: rtdb save state failed', 0) + + call errquit('nbo: rtdb save state failed', 0,0) C C Allocate memory for NBO: C - mem = 2000000 + mem = 20000000 if(.not.MA_Push_Get(MT_Dbl, mem, 'NBO scratch', + lnbo, inbo)) - + call errquit('task_nbo: nbo memory allocation failed',0) + + call errquit('task_nbo: nbo memory allocation failed',0,0) C C Perform NBO analysis: C - if(ga_nodeid().eq.0) then - call RUNNBO(Dbl_MB(inbo), mem) - end if + call RUNNBO(Dbl_MB(inbo), mem) call ga_sync() C C Free memory: C if(.not.MA_Pop_Stack(lnbo)) - + call errquit('task_nbo: lnbo pop stack failed',0) + + call errquit('task_nbo: lnbo pop stack failed',0,0) C C Restore rtdb state: C if(.not.task_restore_state(rtdb, 'nbo')) - + call errquit('nbo: rtdb restore state failed', 0) + + call errquit('nbo: rtdb restore state failed', 0,0) task_nbo = .true. return end @@ -42001,9 +42001,9 @@ in_keylist = .false. do while(.not.eonbo) if(.not.inp_read()) - + call errquit('nbo_input: missing $end in nbo input', 0) + + call errquit('nbo_input: missing $end in nbo input', 0,0) if(.not.inp_a(string)) - + call errquit('nbo_input: inp_a failed', 1) + + call errquit('nbo_input: inp_a failed', 1,0) if(inp_compare(.false., 'end', string)) then if(.not.in_keylist) eonbo = .true. end if @@ -42011,25 +42011,25 @@ nfld = inp_n_field() call inp_set_field(nfld-1) if(.not.inp_a(string)) - + call errquit('nbo_input: inp_a failed', 2) + + call errquit('nbo_input: inp_a failed', 2,0) if(inp_compare(.false., '$end', string)) then in_keylist = .false. else in_keylist = .true. end if if(.not.inp_line(string)) - + call errquit('nbo_input: inp_line failed', 1) + + call errquit('nbo_input: inp_line failed', 1,0) nlines = nlines + 1 write(name,'(a4,i3)') 'nbo:',nlines if(.not.rtdb_cput(rtdb, name, 1, string)) - + call errquit('nbo_input: rtdb_cput failed', 1) + + call errquit('nbo_input: rtdb_cput failed', 1,0) endif end do C C Write number of nbo input lines on rtdb: C if(.not.rtdb_put(rtdb, 'nbo:lines', MT_Int, 1, nlines)) - + call errquit('nbo_input: rtdb_put failed', 0) + + call errquit('nbo_input: rtdb_put failed', 0,0) return end C*********************************************************************** @@ -42042,6 +42042,7 @@ #include "mafdecls.fh" #include "rtdb.fh" #include "stdio.fh" +#include "global.fh" C dimension core(memory),nboopt(10),nmo(2) character*20 theory @@ -42050,11 +42051,16 @@ logical movecs_read_header external movecs_read_header C + PARAMETER(MAXBAS = 2000) + COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,NNAO,MXBO,MXAO,MXAOLM,MUNIT + COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO + LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO + COMMON/NBEDA/KFRG,NFRG,IFRG(MAXBAS),NFE(MAXBAS),NFEB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNLBL,LFNDEF,LFNBRK(100) COMMON/NBNWC/rtdb - integer rtdb + integer rtdb,nbooptorg,inntsize,llogsize C C Set NBO options: C @@ -42078,15 +42084,17 @@ if(nlines.eq.0) nboopt(1) = 1 if(nboopt(1).eq.0) then call util_file_name('nboin', .false., .false., filename) - open(LFNIN, file=filename, status='new', err=100) + if (ga_nodeid().eq.0) + + open(LFNIN, file=filename, status='new', err=100) do 10 iline = 1,nlines write(name, '(a4,i3)') 'nbo:',iline if(.not.rtdb_cget(rtdb, name, 1, string)) - + call errquit('nbo: rtdb_cget failed', 0) - write(LFNIN,'(a)') string + + call errquit('nbo: rtdb_cget failed', 0,0) + if (ga_nodeid().eq.0) write(LFNIN,'(a)') string 10 continue - close(LFNIN, status='keep') - open(LFNIN, file=filename, status='old', err=110) + if (ga_nodeid().eq.0) close(LFNIN, status='keep') + if (ga_nodeid().eq.0) + + open(LFNIN, file=filename, status='old', err=110) else nboopt(7) = 0 end if @@ -42096,13 +42104,20 @@ call util_file_name('movecs', .false., .false., filename) if(.not.movecs_read_header(filename, title, basis, theory, + nbf, nset, nmo, 2)) - + call errquit('nbo: movecs_read_header failed',0) + + call errquit('nbo: movecs_read_header failed',0,0) if(.not.rtdb_cput(rtdb, 'task:theory', 1, theory)) - + call errquit('nbo: theory not modified', 0) + + call errquit('nbo: theory not modified', 0,0) C C Perform the NPA/NBO/NLMO analyses: C + if (ga_nodeid().gt.0) then + nbooptorg=nboopt(1) + nboopt(1)=-2 + endif call NBO(core,memory,nboopt) + if (ga_nodeid().gt.0) then + nboopt(1)=nbooptorg + endif if(nboopt( 1).ne.0) goto 30 if(nboopt(10).lt.0) goto 30 C @@ -42111,23 +42126,39 @@ call util_file_name('nbovecs', .false., .false., filename) write(name,'(a,'':output vectors'')') theory(1:inp_strlen(theory)) if(.not.rtdb_cput(rtdb, name, 1, filename)) - + call errquit('nbo: rtdb_cput output vectors failed', 0) + + call errquit('nbo: rtdb_cput output vectors failed', 0,0) write(name,'(a,'':input vectors'')') theory(1:inp_strlen(theory)) if(.not.rtdb_cput(rtdb, name, 1, filename)) - + call errquit('nbo: rtdb_cput input vectors failed', 0) + + call errquit('nbo: rtdb_cput input vectors failed', 0,0) C C Perform the energetic analysis: C nboopt(7) = 0 20 nboopt(1) = 2 - call NBOEAN(core,memory,nboopt,idone) + if (ga_nodeid().eq.0) call NBOEAN(core,memory,nboopt,idone) + inntsize=MA_sizeof(MT_INT,1,MT_BYTE) + llogsize=MA_sizeof(MT_LOG,1,MT_BYTE) + call ga_brdcst(Msg_Vec_NBF+MSGINT, KFRG, inntsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+1, NFRG, inntsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+2, ISPIN, inntsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+3, ALPHA, llogsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+4, BETA, llogsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+5, idone, inntsize, 0) + call ga_sync() if(idone.ne.0) then nboopt(1) = 0 goto 30 end if call DELSCF(core,core,memory,filename,theory) nboopt(1) = 3 - call NBOEAN(core,memory,nboopt,idone) + if (ga_nodeid().eq.0) call NBOEAN(core,memory,nboopt,idone) + call ga_brdcst(Msg_Vec_NBF+MSGINT, KFRG, inntsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+1, NFRG, inntsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+2, ISPIN, inntsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+3, ALPHA, llogsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+4, BETA, llogsize, 0) + call ga_brdcst(Msg_Vec_NBF+MSGINT+5, idone, inntsize, 0) + call ga_sync() goto 20 C C Restore movecs on rtdb: @@ -42135,10 +42166,10 @@ 30 call util_file_name('movecs', .false., .false., filename) write(name,'(a,'':output vectors'')') theory(1:inp_strlen(theory)) if(.not.rtdb_cput(rtdb, name, 1, filename)) - + call errquit('nbo: rtdb_cput output vectors failed', 0) + + call errquit('nbo: rtdb_cput output vectors failed', 0,0) write(name,'(a,'':input vectors'')') theory(1:inp_strlen(theory)) if(.not.rtdb_cput(rtdb, name, 1, filename)) - + call errquit('nbo: rtdb_cput input vectors failed', 0) + + call errquit('nbo: rtdb_cput input vectors failed', 0,0) C C Close NBO input: C @@ -42225,28 +42256,28 @@ C Load geometry: C if(.not.geom_create(lgeom, 'geometry')) - + call errquit('nbo: geom_create failed', 0) + + call errquit('nbo: geom_create failed', 0,0) if(.not.geom_rtdb_load(rtdb, lgeom, 'geometry')) - + call errquit('nbo: no geometry in rtdb', 0) + + call errquit('nbo: no geometry in rtdb', 0,0) if(.not.geom_ncent(lgeom, ncenters)) - + call errquit('nbo: geom_ncent failed',0) + + call errquit('nbo: geom_ncent failed',0,0) C C Load basis set information: C if(.not.bas_create(lbasis, 'ao basis')) - + call errquit('nbo: bas_create failed', 0) + + call errquit('nbo: bas_create failed', 0,0) if(.not.bas_rtdb_load(rtdb, lgeom, lbasis, 'ao basis')) - + call errquit('nbo: no ao basis set in rtdb', 0) + + call errquit('nbo: no ao basis set in rtdb', 0,0) if(.not.bas_numcont(lbasis,ncont)) - + call errquit('nbo: bas_numcont failed',0) + + call errquit('nbo: bas_numcont failed',0,0) if(.not.rtdb_cget(rtdb, 'task:theory', 1, theory)) - + call errquit('nbo: theory not specified', 0) + + call errquit('nbo: theory not specified', 0,0) write(name,'(a,'':output vectors'')') theory(1:inp_strlen(theory)) if(.not.rtdb_cget(rtdb, name, 1, filename)) - + call errquit('nbo: rtdb_cget failed', 0) + + call errquit('nbo: rtdb_cget failed', 0,0) if(.not.movecs_read_header(filename, title, basis, theory, + NBAS, nset, nmo, 2)) - + call errquit('nbo: movecs_read_header failed',0) + + call errquit('nbo: movecs_read_header failed',0,0) C C Job title: C @@ -42256,7 +42287,7 @@ C write(name,'(a,'':energy'')') theory(1:inp_strlen(theory)) if(.not.rtdb_get(rtdb, name, MT_Dbl, 1, etot)) - + call errquit('nbo: rtdb_get energy failed', 0) + + call errquit('nbo: rtdb_get energy failed', 0,0) core(1) = etot core(2) = etot call NBWRIT(core,2,8) @@ -42275,46 +42306,46 @@ C if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: MOs', + 1, 1, g_movecs)) - + call errquit('nbo: g_movecs', 0) + + call errquit('nbo: g_movecs', 0,0) if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: bond order', + 1, 1, g_bo)) - + call errquit('nbo: g_bo', 0) + + call errquit('nbo: g_bo', 0,0) if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: Fock matrix', + 1, 1, g_fock)) - + call errquit('nbo: g_fock', 0) + + call errquit('nbo: g_fock', 0,0) if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: scratch', + 1, 1, g_scr)) - + call errquit('nbo: g_scr', 0) + + call errquit('nbo: g_scr', 0,0) C C Memory allocations: C if(.not.MA_Push_Get(MT_Dbl, ncenters*3, 'coordinates', + lcoord, icoord)) - + call errquit('nbo: lcoord memory allocation failed',0) + + call errquit('nbo: lcoord memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Dbl, ncenters, 'charges', + lchg, ichg)) - + call errquit('nbo: lchg memory allocation failed',0) + + call errquit('nbo: lchg memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Byte, ncenters*16, 'center tags', + ltags, itags)) - + call errquit('nbo: ltags memory allocation failed',0) + + call errquit('nbo: ltags memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Int, ncont, 'prim/shell', + lprim, iprim)) - + call errquit('nbo: lprim memory allocation failed',0) + + call errquit('nbo: lprim memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Int, ncont, 'contraction pointer', + lptr, iptr)) - + call errquit('nbo: lptr memory allocation failed',0) + + call errquit('nbo: lptr memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Int, ncont, 'shell type', + ltype, itype)) - + call errquit('nbo: ltype memory allocation failed',0) + + call errquit('nbo: ltype memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Int, ncont, 'contraction/shell size', + lcomp, icomp)) - + call errquit('nbo: lcomp memory allocation failed',0) + + call errquit('nbo: lcomp memory allocation failed',0,0) C C Atomic numbers, nuclear charges, and coordinates: C if(.not.geom_cart_get(lgeom, ncenters, Byte_MB(itags), + Dbl_MB(icoord), Dbl_MB(ichg))) - + call errquit('nbo: geom_cart_get failed',0) + + call errquit('nbo: geom_cart_get failed',0,0) NATOMS = 0 do 10 i = 1,ncenters index = itags + (i-1)*16 @@ -42351,7 +42382,7 @@ 14 continue end if 15 continue - if(iu.ne.NATOMS) call errquit('nbo: condense icoord failed', 0) + if(iu.ne.NATOMS) call errquit('nbo: condense icoord failed', 0,0) call dscal(NATOMS*3, toang, Dbl_MB(icoord), 1) call NBWRIT(Dbl_MB(icoord), NATOMS*3, 9) C @@ -42359,10 +42390,10 @@ C do 20 i = 1, NBAS if(.not.bas_bf2ce(lbasis,i,itmp)) - + call errquit('nbo: bas_bf2ce failed',0) + + call errquit('nbo: bas_bf2ce failed',0,0) LCTR(i) = icore(itmp) if(LCTR(i).le.0 .or. LCTR(i).gt.NATOMS) - + call errquit('nbo: unknown atomic center', i) + + call errquit('nbo: unknown atomic center', i,0) 20 continue C C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags: @@ -42396,7 +42427,7 @@ do 30 icont = 1,ncont if(.not.bas_continfo(lbasis, icont, type, num, + ngeno, sphcart)) - + call errquit('nbo: bas_continfo failed',0) + + call errquit('nbo: bas_continfo failed',0,0) Int_MB(itype+icont-1) = type Int_MB(iprim+icont-1) = num Int_MB(iptr+icont-1) = nprim + 1 @@ -42543,7 +42574,7 @@ C else if(type.gt.4) then write(LFNPR,*) ' NBO only handles spdfg functions ' - call errquit('nbo: max angular symmetry exceeded',0) + call errquit('nbo: max angular symmetry exceeded',0,0) end if 30 continue C @@ -42572,13 +42603,13 @@ C if(.not.MA_Push_Get(MT_Dbl, nprim, 'exponents', + lexp, iexp)) - + call errquit('nbo: lexp memory allocation failed',0) + + call errquit('nbo: lexp memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Dbl, nprim, 'coefficients', + lcoef, icoef)) - + call errquit('nbo: lcoef memory allocation failed',0) + + call errquit('nbo: lcoef memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Dbl, nprim*5, 'spdfg', + lspdfg, ispdfg)) - + call errquit('nbo: lspdfg memory allocation failed',0) + + call errquit('nbo: lspdfg memory allocation failed',0,0) is = ispdfg ip = is + nprim id = ip + nprim @@ -42590,9 +42621,9 @@ index = 0 do 80 icont = 1,ncont if(.not.bas_get_exponent(lbasis,icont,Dbl_MB(iexp+index))) - + call errquit('nbo: failed bas_get_exp',0) + + call errquit('nbo: failed bas_get_exp',0,0) if(.not.bas_get_coeff(lbasis,icont,Dbl_MB(icoef+index))) - + call errquit('nbo: failed bas_get_coeff',0) + + call errquit('nbo: failed bas_get_coeff',0,0) index = index + Int_MB(iprim+icont-1) 80 continue call dfill(nprim*5, 0.0d0, Dbl_MB(ispdfg), 1) @@ -42661,24 +42692,24 @@ C if(.not.MA_Push_Get(MT_Dbl, nsq, 'scratch', + lscr,iscr)) - + call errquit('nbo: lscr memory allocation failed',0) + + call errquit('nbo: lscr memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Dbl, NBAS, 'mo evals', + leval, ieval)) - + call errquit('nbo: leval allocation failed',0) + + call errquit('nbo: leval allocation failed',0,0) if(.not.MA_Push_Get(MT_Dbl, NBAS, 'mo occs', + locc, iocc)) - + call errquit('nbo: locc allocation failed',0) + + call errquit('nbo: locc allocation failed',0,0) if(.not.MA_Push_Get(MT_Int, NBAS, 'indices 1', + lind1, iind1)) - + call errquit('nbo: lind1 memory allocation failed',0) + + call errquit('nbo: lind1 memory allocation failed',0,0) if(.not.MA_Push_Get(MT_Int, NBAS, 'indices 2', + lind2, iind2)) - + call errquit('nbo: lind2 memory allocation failed',0) + + call errquit('nbo: lind2 memory allocation failed',0,0) C C Overlap matrix: C - if(.not.int_normalize(lbasis)) - + call errquit('nbo: int_normalize failed', 0) + if(.not.int_normalize(rtdb,lbasis)) + + call errquit('nbo: int_normalize failed', 0,0) call int_init(rtdb,1,lbasis) call schwarz_init(lgeom, lbasis) g_over = ga_create_atom_blocked(lgeom, lbasis, 'overlap') @@ -42692,7 +42723,7 @@ C if(.not.movecs_read(filename, 1, Dbl_MB(iocc), Dbl_MB(ieval), + g_movecs)) - + call errquit('nbo: movecs_read failed',0) + + call errquit('nbo: movecs_read failed',0,0) call ga_get(g_movecs, 1, NBAS, 1, NBAS, Dbl_MB(iscr), NBAS) call NBWRIT(Dbl_MB(iscr), nsq, 40) C @@ -42742,7 +42773,7 @@ C if(.not.movecs_read(filename, 2, Dbl_MB(iocc), Dbl_MB(ieval), + g_movecs)) - + call errquit('nbo: beta movecs_read failed',0) + + call errquit('nbo: beta movecs_read failed',0,0) call ga_get(g_movecs, 1, NBAS, 1, NBAS, Dbl_MB(iscr), NBAS) call NBWRIT(Dbl_MB(iscr), nsq, 41) C @@ -42808,53 +42839,53 @@ C Free handles and destroy arrays: C if(.not.ga_destroy(g_pot)) - + call errquit('nbo: destroy g_pot',0) + + call errquit('nbo: destroy g_pot',0,0) if(.not.ga_destroy(g_kin)) - + call errquit('nbo: destroy g_kin',0) + + call errquit('nbo: destroy g_kin',0,0) if(.not.ga_destroy(g_over)) - + call errquit('nbo: destroy g_over',0) + + call errquit('nbo: destroy g_over',0,0) if(.not.ga_destroy(g_scr)) - + call errquit('nbo: destroy g_scr',0) + + call errquit('nbo: destroy g_scr',0,0) if(.not.ga_destroy(g_fock)) - + call errquit('nbo: destroy g_fock',0) + + call errquit('nbo: destroy g_fock',0,0) if(.not.ga_destroy(g_bo)) - + call errquit('nbo: destroy g_bo',0) + + call errquit('nbo: destroy g_bo',0,0) if(.not.ga_destroy(g_movecs)) - + call errquit('nbo: destroy g_movecs',0) + + call errquit('nbo: destroy g_movecs',0,0) if(.not.MA_Pop_Stack(lind2)) - + call errquit('nbo: lind2 pop stack failed',0) + + call errquit('nbo: lind2 pop stack failed',0,0) if(.not.MA_Pop_Stack(lind1)) - + call errquit('nbo: lind1 pop stack failed',0) + + call errquit('nbo: lind1 pop stack failed',0,0) if(.not.MA_Pop_Stack(locc)) - + call errquit('nbo: locc pop stack failed',0) + + call errquit('nbo: locc pop stack failed',0,0) if(.not.MA_Pop_Stack(leval)) - + call errquit('nbo: leval pop stack failed',0) + + call errquit('nbo: leval pop stack failed',0,0) if(.not.MA_Pop_Stack(lscr)) - + call errquit('nbo: lscr pop stack failed',0) + + call errquit('nbo: lscr pop stack failed',0,0) if(.not.MA_Pop_Stack(lspdfg)) - + call errquit('nbo: lspdfg pop stack failed',0) + + call errquit('nbo: lspdfg pop stack failed',0,0) if(.not.MA_Pop_Stack(lcoef)) - + call errquit('nbo: lcoef pop stack failed',0) + + call errquit('nbo: lcoef pop stack failed',0,0) if(.not.MA_Pop_Stack(lexp)) - + call errquit('nbo: lexp pop stack failed',0) + + call errquit('nbo: lexp pop stack failed',0,0) if(.not.MA_Pop_Stack(lcomp)) - + call errquit('nbo: lcomp pop stack failed',0) + + call errquit('nbo: lcomp pop stack failed',0,0) if(.not.MA_Pop_Stack(ltype)) - + call errquit('nbo: ltype pop stack failed',0) + + call errquit('nbo: ltype pop stack failed',0,0) if(.not.MA_Pop_Stack(lptr)) - + call errquit('nbo: lptr pop stack failed',0) + + call errquit('nbo: lptr pop stack failed',0,0) if(.not.MA_Pop_Stack(lprim)) - + call errquit('nbo: lprim pop stack failed',0) + + call errquit('nbo: lprim pop stack failed',0,0) if(.not.MA_Pop_Stack(ltags)) - + call errquit('nbo: ltags pop stack failed',0) + + call errquit('nbo: ltags pop stack failed',0,0) if(.not.MA_Pop_Stack(lchg)) - + call errquit('nbo: lchg pop stack failed',0) + + call errquit('nbo: lchg pop stack failed',0,0) if(.not.MA_Pop_Stack(lcoord)) - + call errquit('nbo: lcoord pop stack failed',0) + + call errquit('nbo: lcoord pop stack failed',0,0) if(.not.bas_destroy(lbasis)) - + call errquit('nbo: basis destroy failed',0) + + call errquit('nbo: basis destroy failed',0,0) if(.not.geom_destroy(lgeom)) - + call errquit('nbo: geom destroy failed', 0) + + call errquit('nbo: geom destroy failed', 0,0) call ga_sync() return end @@ -42865,12 +42896,14 @@ C----------------------------------------------------------------------- implicit real*8 (a-h,o-z) external PACK,UNPACK +#include "nwc_const.fh" #include "bas.fh" #include "geom.fh" #include "geomP.fh" #include "global.fh" #include "inp.fh" #include "mafdecls.fh" +#include "util.fh" #include "rtdb.fh" C parameter(MAXATM = 200,MAXBAS = 2000) @@ -42911,7 +42944,7 @@ C if(.not.inp_compare(.false., 'scf', theory) .and. + .not.inp_compare(.false., 'dft', theory)) - + call errquit('nbo: deletions require scf or dft', 0) + + call errquit('nbo: deletions require scf or dft', 0,0) C C Reduce NWChem print level: C @@ -42919,9 +42952,13 @@ C C Open the NBO DAF: C + if (ga_nodeid().eq.0) then +c call NBOPEN(.false.,error) if(error) call nbhalt('Error opening NBO DAF in SR DELSCF.') - if(KFRG.gt.0) write(LFNPR,910) KFRG + endif + + if(KFRG.gt.0.and.ga_nodeid().eq.0) write(LFNPR,910) KFRG C C Allocate memory: C @@ -42972,38 +43009,40 @@ lscr2 = ls lscr3 = lscr if(last.gt.memory) - + call errquit('nbo: out of memory in delscf', last-memory) + + call errquit('nbo: out of memory in delscf', last-memory,0) C C Get handles for several global arrays: C if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: nbovecs', + 1, 1, g_nbovecs(1))) - + call errquit('nbo: g_nbovecs(1)', 0) + + call errquit('nbo: g_nbovecs(1)', 0,0) if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: nbovecs', + 1, 1, g_nbovecs(2))) - + call errquit('nbo: g_nbovecs(2)', 0) + + call errquit('nbo: g_nbovecs(2)', 0,0) if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: bond order', + 1, 1, g_bo)) - + call errquit('nbo: g_bo', 0) + + call errquit('nbo: g_bo', 0,0) if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: scratch', + 1, 1, g_scr)) - + call errquit('nbo: g_scr', 0) + + call errquit('nbo: g_scr', 0,0) C C Get geometry and basis set handles: C if(.not.geom_create(lgeom, 'geometry')) - + call errquit('nbo: geom_create failed', 0) + + call errquit('nbo: geom_create failed', 0,0) if(.not.geom_rtdb_load(rtdb, lgeom, 'geometry')) - + call errquit('nbo: no geometry in rtdb', 0) + + call errquit('nbo: no geometry in rtdb', 0,0) if(.not.bas_create(lbasis, 'ao basis')) - + call errquit('nbo: bas_create failed', 0) + + call errquit('nbo: bas_create failed', 0,0) if(.not.bas_rtdb_load(rtdb, lgeom, lbasis, 'ao basis')) - + call errquit('nbo: no ao basis set in rtdb', 0) + + call errquit('nbo: no ao basis set in rtdb', 0,0) if(.not.rtdb_cget(rtdb, 'title', 1, jobname)) - + call errquit('nbo: rtdb_cget title failed', 0) + + call errquit('nbo: rtdb_cget title failed', 0,0) C C NEDA: Save the perturbed density on the DAF: C + if (ga_nodeid().eq.0) then +c if(KFRG.eq.1) then if(UHF) then ALPHA = .true. @@ -43083,12 +43122,14 @@ 30 continue call ga_put(g_nbovecs(1), 1, NBAS, 1, NBAS, a(lt), NBAS) end if +c + endif C C Write the NWChem movecs (nbovecs) file: C if(.not.movecs_write(rtdb, lbasis, filename, theory, jobname, + NBAS, nsets, nmo, a(locca), NBAS, a(leiga), NBAS, g_nbovecs)) - + call errquit('nbo: nbovecs write failed', 0) + + call errquit('nbo: nbovecs write failed', 0,0) C C Modify one-electron integrals and nuclear repulsion: C @@ -43121,7 +43162,7 @@ C if(.not.movecs_read(filename, 1, a(locca), a(leiga), + g_nbovecs(1))) - + call errquit('nbo: nbovecs_read failed',0) + + call errquit('nbo: nbovecs_read failed',0,0) C C Prepare the zero-field density from the MOs and their occupations: C @@ -43138,6 +43179,8 @@ C C Retrieve the zero-field density, pack and save on DAF: C + if (ga_nodeid().eq.0) then +c call ga_get(g_bo, 1, NBAS, 1, NBAS, a(lscr), NBAS) call PACK(a(lscr), NBAS, NBAS) ALPHA = .false. @@ -43146,6 +43189,8 @@ if(KFRG.gt.1) call FEDCP(a(ldmca),NFRG) call COPY(a(lscr),a(ldmca+ioff),ntri,ntri,1) call SVDCP(a(ldmca),NFRG) +c + endif C C Repeat for beta-spin manifold: C @@ -43154,7 +43199,7 @@ if(UHF) then if(.not.movecs_read(filename, 2, a(loccb), a(leigb), + g_nbovecs(2))) - + call errquit('nbo: beta nbovecs_read failed',0) + + call errquit('nbo: beta nbovecs_read failed',0,0) C C Prepare the zero-field density form the MOs and their occupations: C @@ -43172,16 +43217,22 @@ C Retrieve the zero-field density, pack and save on DAF: C call ga_get(g_bo, 1, NBAS, 1, NBAS, a(lscr), NBAS) + if (ga_nodeid().eq.0) then +c call PACK(a(lscr), NBAS, NBAS) ALPHA = .false. BETA = .true. if(KFRG.gt.1) call FEDCP(a(ldmcb),NFRG) call COPY(a(lscr),a(ldmcb+ioff),ntri,ntri,1) call SVDCP(a(ldmcb),NFRG) +c + endif end if C C Translate dipoles to center-of-mass and convert to Debye: C + if (ga_nodeid().eq.0) then +c totm = zero totq = -float(NFE(KFRG)) - float(NFEB(KFRG))*ifuhf do 210 i = 1,3 @@ -43217,6 +43268,8 @@ if(iffld.ne.0) write(LFNPR,950) (dfld(i),i=1,3),dft write(LFNPR,960) (dcp(i), i=1,3),dct write(LFNPR,970) (dind(i),i=1,3),dit +c + endif C C Restore one-electron integrals and nuclear repulsion: C @@ -43225,6 +43278,8 @@ C C Evaluate NEDA components: C + if (ga_nodeid().eq.0) then +c plnrg = zero exnrg = zero do 260 i = 1,NFRG @@ -43232,10 +43287,15 @@ fpnrg(i) = zero fsnrg(i) = zero 260 continue +c + endif +c if(NFRG.gt.0.and.KFRG.eq.NFRG) then C C Retrieve densities from DAF: C + if (ga_nodeid().eq.0) then +c if(UHF) then ALPHA = .true. BETA = .false. @@ -43254,6 +43314,8 @@ call FEDDEF(a(ldmda),NFRG) if(iffld.ne.0) call FEDFLD(a(ldmfa),NFRG) end if +c + endif C C Allocate memory for Fock and density matrices: C @@ -43274,6 +43336,8 @@ C C Stash density matrices in global arrays: C + if (ga_nodeid().eq.0) then +c do 280 i = 1,NFRG ioff = (i - 1) * ntri call COPY(a(ldmca+ioff),a(lscr1),ntri,ntri,1) @@ -43299,6 +43363,8 @@ + a(lscr2), NBAS) end if 280 continue +c + endif C C Set Coulomb and exchange factors: C @@ -43325,18 +43391,20 @@ C call scf_get_fock_param(rtdb, tol2e) call fock_force_direct(rtdb) - if(.not.int_normalize(lbasis)) - + call errquit('nbo: int_normalize failed', 0) + if(.not.int_normalize(rtdb,lbasis)) + + call errquit('nbo: int_normalize failed', 0,0) call int_init(rtdb, 1, lbasis) call schwarz_init(lgeom, lbasis) call fock_2e(lgeom, lbasis, nfock, a(lja), a(lka), tol2e, - + .false., ia(lgda), ia(lgfa)) + + .false., ia(lgda), ia(lgfa), .false.) call schwarz_tidy call fock_2e_tidy(rtdb) call int_terminate() C C Evaluate electronic contributions to NEDA components: C + if (ga_nodeid().eq.0) then +c do 310 i = 1,NFRG ioff = (i - 1) * ntri do 300 j = 1,NFRG @@ -43436,28 +43504,32 @@ 320 continue snrg(i) = snrg(i) / two 330 continue +c + endif C C Destroy global array handles: C do 340 i = 1,3*NFRG if(.not.ga_destroy(ia(lgfa+i-1))) - + call errquit('nbo: destroy fock matrices',0) + + call errquit('nbo: destroy fock matrices',0,0) if(.not.ga_destroy(ia(lgda+i-1))) - + call errquit('nbo: destroy dens matrices',0) + + call errquit('nbo: destroy dens matrices',0,0) if(UHF) then if(.not.ga_destroy(ia(lgfb+i-1))) - + call errquit('nbo: destroy fock matrices',0) + + call errquit('nbo: destroy fock matrices',0,0) if(.not.ga_destroy(ia(lgdb+i-1))) - + call errquit('nbo: destroy dens matrices',0) + + call errquit('nbo: destroy dens matrices',0,0) end if 340 continue end if C C Save energies on DAF: C + if (ga_nodeid().eq.0) then +c call SVE0(eloc) if(NFRG.ne.0) then - len = 4 + 8 * NFRG + len = 5 + 8 * NFRG if(KFRG.eq.0) then a(lscr) = eloc do 350 i = 1,len-1 @@ -43465,43 +43537,54 @@ 350 continue else call NBREAD(a(lscr),len,70) - a(lscr+3+ NFRG+KFRG) = edef - a(lscr+3+2*NFRG+KFRG) = ecp - a(lscr+3+3*NFRG+KFRG) = efld - a(lscr+3+4*NFRG+KFRG) = edff + a(lscr+4+ NFRG+KFRG) = edef + a(lscr+4+2*NFRG+KFRG) = ecp + a(lscr+4+3*NFRG+KFRG) = efld + a(lscr+4+4*NFRG+KFRG) = edff end if if(KFRG.eq.NFRG) then a(lscr+1) = esnrg a(lscr+2) = plnrg a(lscr+3) = exnrg + if(theory.eq.'scf') then + a(lscr+4) = 0.0d0 + else + a(lscr+4) = 1.0d0 + endif do 360 i = 1,NFRG - a(lscr+3 +i) = snrg(i) - a(lscr+3+5*NFRG+i) = fenrg(i) - a(lscr+3+6*NFRG+i) = fpnrg(i) - a(lscr+3+7*NFRG+i) = fsnrg(i) + a(lscr+4 +i) = snrg(i) + a(lscr+4+5*NFRG+i) = fenrg(i) + a(lscr+4+6*NFRG+i) = fpnrg(i) + a(lscr+4+7*NFRG+i) = fsnrg(i) 360 continue end if call NBWRIT(a(lscr),len,70) end if +c + endif C C Destroy global array, geometry, and basis set handles: C if(.not.ga_destroy(g_nbovecs(1))) - + call errquit('nbo: destroy g_movecs',0) + + call errquit('nbo: destroy g_movecs',0,0) if(.not.ga_destroy(g_nbovecs(2))) - + call errquit('nbo: destroy g_movecs',0) + + call errquit('nbo: destroy g_movecs',0,0) if(.not.ga_destroy(g_bo)) - + call errquit('nbo: destroy g_bo',0) + + call errquit('nbo: destroy g_bo',0,0) if(.not.ga_destroy(g_scr)) - + call errquit('nbo: destroy g_scr',0) + + call errquit('nbo: destroy g_scr',0,0) if(.not.bas_destroy(lbasis)) - + call errquit('nbo: basis destroy failed',0) + + call errquit('nbo: basis destroy failed',0,0) if(.not.geom_destroy(lgeom)) - + call errquit('nbo: geom destroy failed', 0) + + call errquit('nbo: geom destroy failed', 0,0) C C Close the NBO DAF: C + if (ga_nodeid().eq.0) then +c call NBCLOS(.false.) +c + endif C C Restore NWChem print level: C @@ -43526,6 +43609,7 @@ C 13-Jun-98 EDG New subroutine C----------------------------------------------------------------------- implicit real*8 (a-h,o-z) +#include "nwc_const.fh" #include "geom.fh" #include "geomP.fh" #include "global.fh" @@ -43554,6 +43638,7 @@ COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,NNAO,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBNWC/rtdb integer rtdb + logical status C save zero,hold,nhold data zero/0.0d0/ @@ -43565,6 +43650,9 @@ C C Update 'geometry' on rtdb: C + status= rtdb_parallel(.false.) + if (ga_nodeid().eq.0) then +c if(ifld.ne.0) then if(iflg.eq.0) then C @@ -43605,10 +43693,10 @@ C Modify the rtdb to reflect the new charge and open shells: C if(.not.rtdb_put(rtdb, 'charge', MT_Dbl, 1, fchg)) - + call errquit('nbo: rtdb_put charge failed', 0) + + call errquit('nbo: rtdb_put charge failed', 0,0) write(name,'(a,'':nopen'')') theory(1:inp_strlen(theory)) if(.not.rtdb_put(rtdb, name, MT_Int, 1, nopen)) - + call errquit('nbo: rtdb_put nopen failed', 0) + + call errquit('nbo: rtdb_put nopen failed', 0,0) C C Otherwise, restore 'geometry' on rtdb: C @@ -43621,12 +43709,14 @@ end if 20 continue if(.not.rtdb_put(rtdb, 'charge', MT_Dbl, 1, hold)) - + call errquit('nbo: rtdb_put hold failed', 0) + + call errquit('nbo: rtdb_put hold failed', 0,0) write(name,'(a,'':nopen'')') theory(1:inp_strlen(theory)) if(.not.rtdb_put(rtdb, name, MT_Int, 1, nhold)) - + call errquit('nbo: rtdb_put nhold failed', 0) + + call errquit('nbo: rtdb_put nhold failed', 0,0) end if end if +c + endif C C Electric field: C @@ -43635,14 +43725,25 @@ C C Store 'geometry' on rtdb: C + if (ga_nodeid().eq.0) then if(.not.geom_rtdb_store(rtdb, lgeom, 'geometry')) - + call errquit('nbo: geom_rtdb_store failed', 0) + + call errquit('nbo: geom_rtdb_store failed', 0,0) + endif + status= rtdb_parallel(.true.) +c + if(.not.geom_rtdb_load(rtdb, lgeom, 'geometry')) + + call errquit('nbo: geom_rtdb_load failed', 0,0) + if(.not.rtdb_get(rtdb, 'charge', MT_Dbl, 1, fchg)) + + call errquit('nbo: rtdb_get charge failed', 0,0) + write(name,'(a,'':nopen'')') theory(1:inp_strlen(theory)) + if(.not.rtdb_get(rtd b, name, MT_Int, 1, nopen)) + + call errquit('nbo: rtdb_get nopen failed', 0,0) C C Compute the nuclear attraction integrals for the current fragment: C if(iflg.eq.0.and..not.oefield(lgeom)) then - if(.not.int_normalize(lbasis)) - + call errquit('nbo: int_normalize failed', 0) + if(.not.int_normalize(rtdb,lbasis)) + + call errquit('nbo: int_normalize failed', 0,0) call int_init(rtdb,1,lbasis) call schwarz_init(lgeom, lbasis) C @@ -43659,6 +43760,8 @@ C C Retrieve integrals from global array, pack, and store on DAF: C + if (ga_nodeid().eq.0) then +c call ga_get(g_pot, 1, NBAS, 1, NBAS, scr, NBAS) ntri = NBAS * (NBAS+1) / 2 call PACK(scr, NBAS, NBAS) @@ -43666,17 +43769,19 @@ if(KFRG.gt.1) call FEVNUC(vnuc,NFRG) call COPY(scr,vnuc(ioff+1),ntri,ntri,1) call SVVNUC(vnuc,NFRG) +c + endif C C Destroy global array handle: C if(.not.ga_destroy(g_pot)) - + call errquit('nbo: destroy g_pot',0) + + call errquit('nbo: destroy g_pot',0,0) end if C C Recalculate the nuclear repulsion energy: C if(.not.geom_nuc_rep_energy(lgeom, enuc)) - + call errquit('nbo: geom_nuc_rep_energy failed', 0) + + call errquit('nbo: geom_nuc_rep_energy failed', 0,0) oefield(lgeom) = eflag end if C @@ -43685,20 +43790,20 @@ if(NFRG.ne.0.and.iflg.eq.0.and.ifld.eq.1) then if(KFRG.eq.0) then if(.not.geom_nuc_rep_energy(lgeom, esnrg)) - + call errquit('nbo: geom_nuc_rep_energy failed', 1) + + call errquit('nbo: geom_nuc_rep_energy failed', 1,0) else eflag = oefield(lgeom) oefield(lgeom) = .false. bqflag = geom_include_bqbq(lgeom) if(.not.geom_set_bqbq(lgeom, .false.)) - + call errquit('nbo: geom_set_bqbq failed', 0) + + call errquit('nbo: geom_set_bqbq failed', 0,0) if(.not.geom_nuc_rep_energy(lgeom, etmp)) - + call errquit('nbo: geom_nuc_rep_energy failed', 2) + + call errquit('nbo: geom_nuc_rep_energy failed', 2,0) esnrg = esnrg - etmp fenrg(KFRG) = enuc - etmp oefield(lgeom) = eflag if(.not.geom_set_bqbq(lgeom, bqflag)) - + call errquit('nbo: geom_set_bqbq failed', 0) + + call errquit('nbo: geom_set_bqbq failed', 0,0) end if end if return @@ -43732,12 +43837,12 @@ if(.not.rtdb_get(rtdb, 'charge', MT_Dbl, 1, charge)) + charge = zero if(.not.geom_nuc_charge(lgeom, chgnuc)) - + call errquit('nbo: geom_nuc_charge failed', 0) + + call errquit('nbo: geom_nuc_charge failed', 0,0) nelec = nint(chgnuc - charge) if(abs(chgnuc - charge - dble(nelec)) .gt. 1d-8) - + call errquit('nbo: non-integral no. of electrons?', 0) + + call errquit('nbo: non-integral no. of electrons?', 0,0) if(nelec .lt. 0) - + call errquit('nbo: negative no. of electrons?', 0) + + call errquit('nbo: negative no. of electrons?', 0,0) C C If zero electrons, then zero energy and dipole moment: C @@ -43745,9 +43850,9 @@ edef = zero ecp = zero if(.not.geom_nuc_dipole(lgeom,ddef)) - + call errquit('nbo: geom_nuc_dipole (ddef) failed', 0) + + call errquit('nbo: geom_nuc_dipole (ddef) failed', 0,0) if(.not.geom_nuc_dipole(lgeom,dcp)) - + call errquit('nbo: geom_nuc_dipole (dcp) failed', 0) + + call errquit('nbo: geom_nuc_dipole (dcp) failed', 0,0) return end if C @@ -43757,14 +43862,14 @@ if(.not.rtdb_get(rtdb, 'scf:maxiter', MT_Int, 1, itsdef)) + itsdef = 20 if(.not.rtdb_put(rtdb, 'scf:maxiter', MT_Int, 1, abs(its))) - + call errquit('nbo: rtdb_put scf maxiter failed', 0) + + call errquit('nbo: rtdb_put scf maxiter failed', 0,0) else if(inp_compare(.false., 'dft', theory)) then if(.not.rtdb_put(rtdb, 'dft:iterations', MT_Int, 1, itsdef)) + itsdef = 30 if(.not.rtdb_put(rtdb, 'dft:iterations', MT_Int, 1, abs(its))) - + call errquit('nbo: rtdb_put dft iterations failed', 0) + + call errquit('nbo: rtdb_put dft iterations failed', 0,0) else - call errquit('nbo: unknown theory', 0) + call errquit('nbo: unknown theory', 0,0) end if C C Compute energy: @@ -43776,7 +43881,7 @@ C write(name,'(a,'':energy'')') theory(1:inp_strlen(theory)) if(.not.rtdb_get(rtdb, name, MT_Dbl, 1, etot)) - + call errquit('nbo: rtdb_get energy failed', 0) + + call errquit('nbo: rtdb_get energy failed', 0,0) edef = etot ecp = 0.0d0 C @@ -43784,38 +43889,38 @@ C write(name,'(a,'':dipole'')') theory(1:inp_strlen(theory)) if(.not.rtdb_get(rtdb, name, MT_Dbl, 3, ddef)) - + call errquit('nbo: rtdb_get dipole failed', 0) + + call errquit('nbo: rtdb_get dipole failed', 0,0) C C Reset iterations: C if(inp_compare(.false., 'scf', theory)) then if(.not.rtdb_put(rtdb, 'scf:maxiter', MT_Int, 1, itsdef)) - + call errquit('nbo: rtdb_put scf maxiter failed', 0) + + call errquit('nbo: rtdb_put scf maxiter failed', 0,0) else if(inp_compare(.false., 'dft', theory)) then if(.not.rtdb_put(rtdb, 'dft:iterations', MT_Int, 1, itsdef)) - + call errquit('nbo: rtdb_put dft iterations failed', 0) + + call errquit('nbo: rtdb_put dft iterations failed', 0,0) else - call errquit('nbo: unknown theory', 0) + call errquit('nbo: unknown theory', 0,0) end if C C Variationally optimize the wavefunction: C if(its.lt.0) then if(.not.task_energy(rtdb)) - + call errquit('nbo: no convergence in NEDA', 0) + + call errquit('nbo: no convergence in NEDA', 0,0) C C Retrieve energy from rtdb: C write(name,'(a,'':energy'')') theory(1:inp_strlen(theory)) if(.not.rtdb_get(rtdb, name, MT_Dbl, 1, etot)) - + call errquit('nbo: rtdb_get energy failed', 0) + + call errquit('nbo: rtdb_get energy failed', 0,0) ecp = etot C C Retrieve dipole from rtdb: C write(name,'(a,'':dipole'')') theory(1:inp_strlen(theory)) if(.not.rtdb_get(rtdb, name, MT_Dbl, 3, dcp)) - + call errquit('nbo: rtdb_get dipole failed', 1) + + call errquit('nbo: rtdb_get dipole failed', 1,0) end if C C Reset energy on rtdb: @@ -43823,7 +43928,7 @@ call FEE0(dum,etot) write(name,'(a,'':energy'')') theory(1:inp_strlen(theory)) if(.not.rtdb_put(rtdb, name, MT_Dbl, 1, etot)) - + call errquit('nbo: rtdb_put energy failed', 0) + + call errquit('nbo: rtdb_put energy failed', 0,0) return end C*********************************************************************** @@ -43870,7 +43975,7 @@ C Get theory from rtdb and prepare to write ecce output: C if(.not.rtdb_cget(rtdb, 'task:theory', 1, theory)) - + call errquit('nbo: rtdb_cget theory failed', 0) + + call errquit('nbo: rtdb_cget theory failed', 0,0) call ecce_print_module_entry(theory) C C Allocate memory: @@ -43888,7 +43993,7 @@ C Allocate global array: C if(.not.ga_create(MT_Dbl, NBAS, NBAS, 'nbo: checkpoint vectors', - + 1, 1, g_chk)) call errquit('nbo: g_chk', 0) + + 1, 1, g_chk)) call errquit('nbo: g_chk', 0,0) C C Closed shell or alpha orbitals: C @@ -43900,14 +44005,14 @@ ALPHA = .true. end if call FECHK(a(lt),is,it) - if(it.eq.0) call errquit('nbo: checkpoint failed', is) + if(it.eq.0) call errquit('nbo: checkpoint failed', is,0) call ga_put(g_chk, 1, NBAS, 1, NBAS, a(lt), NBAS) call FEDRAW(a(ldm),a(lscr)) call FESRAW(a(ls)) call SIMTRS(a(ldm),a(ls),a(lscr),NDIM,NBAS) call SIMTRS(a(ldm),a(lt),a(lscr),NDIM,NBAS) call FEFAO(a(lf),iwfock) - if(iwfock.eq.0) call errquit('nbo: missing Fock matrix', is) + if(iwfock.eq.0) call errquit('nbo: missing Fock matrix', is,0) call SIMTRS(a(lf),a(lt),a(lscr),NDIM,NBAS) do 10 i = 1,NBAS ioff = (i-1) * (NBAS+1) @@ -43933,14 +44038,14 @@ BETA = .true. is = -2 call FECHK(a(lt),is,it) - if(it.eq.0) call errquit('nbo: checkpoint failed', is) + if(it.eq.0) call errquit('nbo: checkpoint failed', is,0) call ga_put(g_chk, 1, NBAS, 1, NBAS, a(lt), NBAS) call FEDRAW(a(ldm),a(lscr)) call FESRAW(a(ls)) call SIMTRS(a(ldm),a(ls),a(lscr),NDIM,NBAS) call SIMTRS(a(ldm),a(lt),a(lscr),NDIM,NBAS) call FEFAO(a(lf),iwfock) - if(iwfock.eq.0) call errquit('nbo: missing Fock matrix', is) + if(iwfock.eq.0) call errquit('nbo: missing Fock matrix', is,0) call SIMTRS(a(lf),a(lt),a(lscr),NDIM,NBAS) do 20 i = 1,NBAS ioff = (i-1) * (NBAS+1) @@ -43958,7 +44063,7 @@ C Destroy global array handle C if(.not.ga_destroy(g_chk)) - + call errquit('nbo: destroy g_chk',0) + + call errquit('nbo: destroy g_chk',0,0) C C Finish up: C