1 Program asc2mov 2 Implicit NONE 3C 4C Reads formatted (ASCII) movecs file, writes binary version 5C 6C Usage: asc2mov guess_nbf infile outfile 7C 8C guess_nbf must be at least as large as the NBF in the file to be 9C translated. 10C 11C The format of the ASCII file is exactly as the companion program 12C mov2asc writes it. 13C 14C $Id$ 15C 16#include "mafdecls.fh" 17c 18c Temporary routine 19c 20 character*(255) data, bfilename, afilename 21 character*(255) title ! Returns title of job that created vectors 22 character*(255) basis_name ! Returns name of basis set 23 integer nbf ! Returns no. of functions in basis 24 integer nsets ! Returns no. of functions in each set 25 integer ldnmo ! Inputs size of nmo 26 parameter(ldnmo = 10) 27 integer nmo(ldnmo) ! Returns no. of vectors in each set 28c 29 integer binlu,asclu ! Unit no. for writeing 30 parameter (binlu = 67,asclu = 68) ! These need to be managed !!! 31 integer lentit 32 integer lenbas 33 integer ok, i, guess_nbf, NArgs, jset, j, k_vecs, l_vecs 34 character*32 geomsum, basissum, bqsum 35 character*26 date 36 character*20 scftype20 37C 38#if defined(CRAY) 39 integer*4 length,ierror,iarg 40#else 41 Integer IArgc 42#if (__GNUC__ < 4) 43 External IArgc 44#endif 45#endif 46C 47 double precision energy, enrep 48C Interpret command line 49C 50#ifdef CRAY 51 integer*4 ipxfargc 52 external ipxfargc 53 nargs =ipxfargc() 54#else 55 NArgs = IArgc() 56#endif 57 If ( NArgs .ne. 3) then 58 Write (0, *) 'Usage: asc2mov guess_nbf infile outfile' 59 Call Exit(1) 60 EndIf 61#ifdef CRAY 62 iarg=1 63 Call pxfGetArg(iarg, data, length, ierror) 64#else 65 Call GetARg(1, data) 66#endif 67 Read(Data, '(I10)') Guess_NBF 68#ifdef CRAY 69 iarg=2 70 Call pxfGetArg(iarg, afilename, 255, ok) 71 iarg=3 72 Call pxfGetArg(iarg, bfilename, 255, ok) 73#else 74 Call GetARg(2, afilename) 75 Call GetARg(3, bfilename) 76#endif 77C 78c$$$ Write (6, 9000) Guess_NBF, Bfilename, Afilename 79c$$$ 9000 Format('Arguments ', I10, 5X, '+', A, '+', '+', A, '+') 80c$$$C 81 If ( .NOT. MA_Init(Mt_Dbl, Guess_NBF, 0)) Call ErrQuit( 82 $ 'Unable to initialize memory', Guess_NBF) 83c 84 open(binlu, status='unknown', form='unformatted', file=bfilename) 85 open(asclu, status='old', form='formatted', file=afilename) 86C 87 Read(AscLu, *) 88c 89 read(asclu,'(a32)') basissum 90 read(asclu,'(a32)') geomsum 91 read(asclu,'(a32)') bqsum 92 read(asclu,'(a20)') scftype20 93 read(asclu,'(a26)') date 94 write(binlu) basissum, geomsum, bqsum, scftype20, date 95c 96 read(asclu,'(a20)') scftype20 97 write(binlu) scftype20 98C 99 read(asclu, '(I10)') LenTit 100 write(binlu) lentit 101C 102 title = ' ' 103 Read(AscLu, '(A)') Title(1:LenTit) 104 write(binlu) title(1:lentit) 105C 106 Read (AscLu, '(I10)') LenBas 107 if (len(basis_name) .lt. lenbas) call errquit 108 $ ('movecs_write_header: basis_name too short', lenbas) 109 write(binlu) lenbas 110C 111 basis_name = ' ' 112 Read( AscLu, '(A)') Basis_Name(1:LenBas) 113 write(binlu) basis_name(1:lenbas) 114C 115 Read( AscLu, '(I10)') NSets 116 write(binlu) nsets 117C 118 Read( AscLu, '(I10)') NBF 119 write(binlu) nbf 120C 121 if (nsets .gt. ldnmo) then 122 Write(6,*) ' movecs_write_header: ldnmo too small ', 123 $ nsets, ldnmo 124 close(binlu) 125 close(asclu) 126 Stop 127 endif 128 Read( AscLu, '(7(I10,X))') (nmo(i),i=1,nsets) 129 write(binlu) (nmo(i),i=1,nsets) 130c 131 If ( Guess_NBF .lt. NBF ) Call ErrQuit( 132 $ 'Guessed too small for NBF. Actual is', NBF) 133 If ( .NOT. MA_Push_Get(MT_Dbl, NBF, 'temporary vector', l_vecs, 134 $ k_vecs)) Call ErrQuit('Failed to allocate temp vector', NBF) 135C 136 do jset = 1, Nsets 137 Read(Asclu, '(3E25.15)') (dbl_mb(k_vecs+j),j=0,nbf-1) 138 write(binlu) (dbl_mb(k_vecs+j),j=0,nbf-1) ! Occupation numbers 139C 140 Read(Asclu, '(3E25.15)') (dbl_mb(k_vecs+j),j=0,nbf-1) 141 write(binlu) (dbl_mb(k_vecs+j),j=0,nbf-1) ! Eigenvalues 142C 143 do i = 1, nmo(jset) 144 Read(Asclu, '(3E25.15)') (dbl_mb(k_vecs+j),j=0,nbf-1) 145 write(binlu) (dbl_mb(k_vecs+j),j=0,nbf-1) ! An eigenvector 146 enddo 147 enddo 148C 149 read(Asclu,'(2E25.15)',err=901,end=901) energy, enrep 150 write(binlu) energy, enrep 151 goto 902 152 901 write(binlu) 0.0,0.0 153 902 continue 154c 155 close(binlu) 156 Close(AscLu) 157C 158 if (.not. ma_pop_stack(l_vecs)) call errquit 159 $ ('movecs_write: pop failed', l_vecs) 160C 161 Stop 162 End 163 Subroutine ErrQuit(Msg, Num) 164 Implicit NONE 165 Character*(*) Msg 166 Integer Num 167 Write (0, '(A,1X, I10)') Msg, Num 168 Call Exit(1) 169 Return 170 End 171