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