      SUBROUTINE READMO
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      INCLUDE 'SIZES'
C
C MODULE TO READ IN GEOMETRY FILE, OUTPUT IT TO THE USER,
C AND CHECK THE DATA TO SEE IF IT IS REASONABLE.
C EXIT IF NECESSARY.
C
C
C
C  ON EXIT NATOMS    = NUMBER OF ATOMS PLUS DUMMY ATOMS (IF ANY).
C          KEYWRD    = KEYWORDS TO CONTROL CALCULATION
C          KOMENT    = COMMENT CARD
C          TITLE     = TITLE CARD
C          LABELS    = ARRAY OF ATOMIC LABELS INCLUDING DUMMY ATOMS.
C          GEO       = ARRAY OF INTERNAL COORDINATES.
C          LOPT      = FLAGS FOR OPTIMIZATION OF MOLECULE
C          NA        = ARRAY OF LABELS OF ATOMS, BOND LENGTHS.
C          NB        = ARRAY OF LABELS OF ATOMS, BOND ANGLES.
C          NC        = ARRAY OF LABELS OF ATOMS, DIHEDRAL ANGLES.
C          LATOM     = LABEL OF ATOM OF REACTION COORDINATE.
C          LPARAM    = RC: 1 FOR LENGTH, 2 FOR ANGLE, AND 3 FOR DIHEDRAL
C          REACT(200)= REACTION COORDINATE PARAMETERS
C          LOC(1,I)  = LABEL OF ATOM TO BE OPTIMIZED.
C          LOC(2,I)  = 1 FOR LENGTH, 2 FOR ANGLE, AND 3 FOR DIHEDRAL.
C          NVAR      = NUMBER OF PARAMETERS TO BE OPTIMIZED.
C          XPARAM    = STARTING VALUE OF PARAMETERS TO BE OPTIMIZED.
C
************************************************************************
C *** INPUT THE TRIAL GEOMETRY  \IE.  KGEOM=0\
C   LABEL(I) = THE ATOMIC NUMBER OF ATOM\I\.
C            = 99, THEN THE I-TH ATOM IS A DUMMY ATOM USED ONLY TO
C              SIMPLIFY THE DEFINITION OF THE MOLECULAR GEOMETRY.
C   GEO(1,I) = THE INTERNUCLEAR SEPARATION \IN ANGSTROMS\ BETWEEN ATOMS
C              NA(I) AND (I).
C   GEO(2,I) = THE ANGLE NB(I):NA(I):(I) INPUT IN DEGREES; STORED IN
C              RADIANS.
C   GEO(3,I) = THE ANGLE BETWEEN THE VECTORS NC(I):NB(I) AND NA(I):(I)
C              INPUT IN DEGREES - STORED IN RADIANS.
C  LOPT(J,I) = -1 IF GEO(J,I) IS THE REACTION COORDINATE.
C            = +1 IF GEO(J,I) IS A PARAMETER TO BE OPTIMIZED
C            =  0 OTHERWISE.
C *** NOTE:    MUCH OF THIS DATA IS NOT INCLUDED FOR THE FIRST 3 ATOMS.
C     ATOM1  INPUT LABELS(1) ONLY.
C     ATOM2  INPUT LABELS(2) AND GEO(1,2) SEPARATION BETWEEN ATOMS 1+2
C     ATOM3  INPUT LABELS(3), GEO(1,3)    SEPARATION BETWEEN ATOMS 2+3
C              AND GEO(2,3)              ANGLE ATOM1 : ATOM2 : ATOM3
C
************************************************************************
C
      DIMENSION LOPT(3,NUMATM)
      CHARACTER KEYWRD*241, KOMENT*81, TITLE*81, LINE*80, BANNER*80
      CHARACTER KEYS(80)*1, SPACE*1, SPACE2*2, CH*1, CH2*2
      CHARACTER ELEMNT*2, IDATE*24, GETNAM*80, NAME*4
      COMMON /KEYWRD/ KEYWRD
      COMMON /TITLES/ KOMENT,TITLE
      COMMON /GEOVAR/ NVAR, LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR)
      COMMON /PATH  / LATOM,LPARAM,REACT(200)
      COMMON /MESH  / LATOM1, LPARA1, LATOM2, LPARA2
      COMMON /ELEMTS/ ELEMNT(107)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),
     * NMIDLE(NUMATM),NLAST(NUMATM),NORBS,NELECS,NALPHA,NBETA,
     * NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /OKMANY/ ISOK
      PARAMETER (MXDIM=MAXORB+NUMATM)
      COMMON /SYMRES/ TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDX(MXDIM),
     * ISTA(2)
      COMMON /ISTOPE/ AMS(107)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /NUMCAL/ NUMCAL
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR),
     1                      LOCDEP(MAXPAR)
      LOGICAL INT, AIGEO, ISOK
      SAVE SPACE, SPACE2, IREACT, INT
      DIMENSION COORD(3,NUMATM),VALUE(40)
      EQUIVALENCE (KEYS(1),KEYWRD)
      DATA SPACE, SPACE2/' ','  '/
      CONVTR=2.D0*ASIN(1.D0)/180.D0
      AIGEO=.FALSE.
   10 CONTINUE
C
      CALL GETTXT
      IF(INDEX(KEYWRD,'ECHO').NE.0)THEN
         REWIND 5
         ISOK=.FALSE.
         DO 50 I=1,1000
            READ(5,'(A)',END=60)KEYWRD
            DO 20 J=80,2,-1
   20       IF(KEYWRD(J:J).NE.' ')GOTO 30
            J=1
   30       DO 40 K=1,J
   40       IF(ICHAR(KEYWRD(K:K)).LT.32)KEYWRD(K:K)='*'
            WRITE(6,'(1X,A)')KEYWRD(1:J)
   50    CONTINUE
   60    CONTINUE
         REWIND 5
         CALL GETTXT
      ENDIF
      IF(INDEX(KEYWRD,'ECHO').NE.0)WRITE(6,'(''1'')')
      IF(KEYWRD(1:1) .NE. SPACE) THEN
         CH=KEYWRD(1:1)
         KEYWRD(1:1)=SPACE
         DO 70 I=2,239
            CH2=KEYWRD(I:I)
            KEYWRD(I:I)=CH
            CH=CH2
            IF(KEYWRD(I+1:I+2) .EQ. SPACE2) THEN
               KEYWRD(I+1:I+1)=CH
               GOTO 80
            ENDIF
   70    CONTINUE
         CH2=KEYWRD(240:240)
         KEYWRD(240:240)=CH
         KEYWRD(241:241)=CH2
   80    CONTINUE
      ENDIF
      IF(KOMENT(1:1) .NE. SPACE) THEN
         CH=KOMENT(1:1)
         KOMENT(1:1)=SPACE
         DO 90 I=2,79
            CH2=KOMENT(I:I)
            KOMENT(I:I)=CH
            CH=CH2
            IF(KOMENT(I+1:I+2) .EQ. SPACE2) THEN
               KOMENT(I+1:I+1)=CH
               GOTO 100
            ENDIF
   90    CONTINUE
         CH2=KOMENT(80:80)
         KOMENT(80:80)=CH
         KOMENT(81:81)=CH2
  100    CONTINUE
      ENDIF
      IF(TITLE(1:1) .NE. SPACE) THEN
         CH=TITLE(1:1)
         TITLE(1:1)=SPACE
         DO 110 I=2,79
            CH2=TITLE(I:I)
            TITLE(I:I)=CH
            CH=CH2
            IF(TITLE(I+1:I+2) .EQ. SPACE2) THEN
               TITLE(I+1:I+1)=CH
               GOTO 120
            ENDIF
  110    CONTINUE
         CH2=TITLE(80:80)
         TITLE(80:80)=CH
         TITLE(81:81)=CH2
  120    CONTINUE
      ENDIF
      DO 121 I=1,200
  121 REACT(I)=0.D0
      LATOM=0
      LPARAM=0
      IF(INDEX(KEYWRD,'OLDGEO').EQ.0) THEN
         NVAR=0
         NDEP=0
         IF(AIGEO.OR.INDEX(KEYWRD,'AIGIN').NE.0)THEN
            CALL GETGEG(5,LABELS,GEO,     NA,NB,NC,AMS,NATOMS,INT)
         IF(NVAR.EQ.0)THEN
         DO 122 J=1,3
         DO 122 I=1,NATOMS
  122    LOPT(J,I)=0
         ENDIF
         ELSE
            CALL GETGEO(5,LABELS,GEO,LOPT,NA,NB,NC,AMS,NATOMS,INT)
            IF(NATOMS.LT.0)THEN
               REWIND 5
               IF(NUMCAL.NE.1)THEN
                  WRITE(6,'(//,A)')'   GAUSSIAN INPUT REQUIRES STAND-ALO
     1NE JOB'
                  WRITE(6,'(/,A)')'   OR KEYWORD "AIGIN"'
                  STOP
               ENDIF
               AIGEO=.TRUE.
               GOTO 10
            ENDIF
         ENDIF
         IF(NATOMS.EQ.0)STOP
      ELSE
      DEGREE=90.D0/ASIN(1.D0)
      IF(NA(1).EQ.99)THEN
      DO 128 I=1,NATOMS
      DO 128 J=1,3
      LOPT(J,I)=1
  128 COORD(J,I)=GEO(J,I)
      LOPT(1,1)=0
      LOPT(2,1)=0
      LOPT(3,1)=0
      LOPT(2,2)=0
      LOPT(3,2)=0
      LOPT(3,3)=0
      CALL XYZINT(COORD,NATOMS,NA,NB,NC,DEGREE,GEO)
      ELSE
      DO 130 I=1,NATOMS
      DO 130 J=2,3
 130  GEO(J,I)=GEO(J,I)*DEGREE
      ENDIF
      ENDIF
      IF(INDEX(KEYWRD,'FORCE').NE.0 .AND. LABELS(NATOMS).EQ.107) THEN
      DO 131 I=1,NA(NATOMS)
      IF(LABELS(I).EQ.99)THEN
      WRITE(6,'(A)')' NO DUMMY ATOMS ALLOWED BEFORE TRANSLATION'
      WRITE(6,'(A)')' ATOM IN A FORCE CALCULATION'
      STOP
      ENDIF
  131 CONTINUE
      ENDIF
C
C
C OUTPUT FILE TO UNIT 6
C
C    WRITE HEADER
      IDATE=' '
      CALL fdate(IDATE)
      WRITE(6,'(1X,15(''*****''),''****'')')
C
C     CHANGE THE FOLLOWING LINE TO SUIT LOCAL ENVIRONMENT, IF DESIRED
C
      BANNER=' ** MOPAC (PUBLIC DOMAIN) FOR DEVELOPMENT USE '//
     1'ONLY.  NOT FOR PRODUCTION WORK  **'
      WRITE(6,'(A)')BANNER
C
C    THE BANNER DOES NOT APPEAR ANYWHERE ELSE.
C
      WRITE(6,'(1X,79(''*''))')
      LINE='   MNDO'
      IF(INDEX(KEYWRD,'MINDO') .NE. 0) LINE='MINDO/3'
      IF(INDEX(KEYWRD,'AM1')   .NE. 0) LINE='    AM1'
      IF(INDEX(KEYWRD,'PM3')   .NE. 0) LINE='    PM3'
      WRITE(6,'(/29X,A,'' CALCULATION RESULTS'',28X,///1X,15(''*****'')
     1,''****'' )')LINE(:7)
      WRITE(6,'('' *'',10X,''MOPAC:  VERSION '',F5.2,
     115X,''CALC''''D. '',A)') VERSON, IDATE
C
C CONVERT ANGLES TO RADIANS
      DO 140 J=2,3
C$DOIT VBEST
         DO 140 I=1,NATOMS
            GEO(J,I) = GEO(J,I) * CONVTR
  140 CONTINUE
C
C CHECK DATA
C
      NA(1)=0
      NB(1)=0
      NC(1)=0
      DO 150 I=1,NATOMS
         IF (LABELS(I) .LE. 0 ) THEN
            WRITE(6,'('' ATOMIC NUMBER OF '',I3,'' ?'')') LABELS(I)
            IF(I.EQ.1) THEN
               WRITE(6,'(A)')' THIS WAS THE FIRST ATOM'
            ELSE
               WRITE(6,'(A)')'    GEOMETRY UP TO, BUT NOT INCLUDING, THE
     1'//' FAULTY ATOM'
               NATOMS=I-1
               CALL GEOUT(6)
            ENDIF
            STOP
         ENDIF
         IF (  NA(I).GE.I.OR. NB(I).GE.I.OR. NC(I).GE.I
     1  .OR. (NA(I).EQ.NB(I))   .AND. I.GT.1
     2  .OR. (NA(I).EQ.NC(I).OR.NB(I).EQ.NC(I))  .AND. I.GT.2
     3  .OR.  NA(I)*NB(I)*NC(I).EQ.0  .AND. I.GT.3) THEN
            WRITE(6,'('' ATOM NUMBER '',I3,'' IS ILL-DEFINED'')') I
            IF(I.EQ.1)STOP
            WRITE(6,'(/,''  GEOMETRY READ IN'',/)')
            CALL GEOUT(6)
            STOP
         ENDIF
  150 CONTINUE
C
C WRITE KEYWORDS BACK TO USER AS FEEDBACK
      CALL WRTKEY(KEYWRD)
      WRITE(6,'(1X,14(''*****''),''*'',I3.3,''BY'',I3.3)')MAXHEV,MAXLIT
C
C FILL IN GEO MATRIX IF NEEDED
      IF(INDEX(KEYWRD,'OLDGEO').EQ.0.AND.INDEX(KEYWRD,'SYM') .NE. 0
     1.AND. NDEP.EQ.0) CALL GETSYM
      IF(NDEP.NE.0) CALL SYMTRY
C
C INITIALIZE FLAGS FOR OPTIMIZE AND PATH
      IFLAG = 0
      LATOM = 0
      NUMAT=0
      IF(NVAR.NE.0)THEN
         NUMAT=NATOMS
      ELSE
         DO 180 I=1,NATOMS
            IF(LABELS(I).NE.99.AND.LABELS(I).NE.107)NUMAT=NUMAT+1
            DO 180 J=1,3
               IF (LOPT(J,I) ) 160, 180, 170
C    FLAG FOR PATH
  160          CONVRT=1.D0
               IF ( IFLAG .NE. 0 ) THEN
                  IF(INDEX(KEYWRD,'STEP1').NE.0)THEN
                     LPARA1=LPARAM
                     LATOM1=LATOM
                     LPARA2=J
                     LATOM2=I
                     LATOM=0
                     IFLAG=0
                     GOTO 180
                  ELSE
                     WRITE(6,'('' ONLY ONE REACTION COORDINATE PERMITTED
     1'')')
                     STOP
                  ENDIF
               ENDIF
               LATOM  = I
               LPARAM = J
               IF(J.GT.1) CONVRT=0.01745329252D00
               REACT(1)  = GEO(J,I)
               IREACT=1
               IFLAG = 1
               GO TO 180
C    FLAG FOR OPTIMIZE
  170          NVAR = NVAR + 1
               LOC(1,NVAR) = I
               LOC(2,NVAR) = J
               XPARAM(NVAR)   = GEO(J,I)
  180    CONTINUE
      ENDIF
C READ IN PATH VALUES
      IF(IFLAG.EQ.0) GO TO 220
      IF(INDEX(KEYWRD,'NLLSQ').NE.0)THEN
         WRITE(6,'(A)')' NLLSQ USED WITH REACTION PATH; '//
     1'THIS OPTION IS NOT ALLOWED'
         STOP
      ENDIF
      IF(INDEX(KEYWRD,'SIGMA').NE.0)THEN
         WRITE(6,'(A)')' SIGMA USED WITH REACTION PATH; '//
     1'THIS OPTION IS NOT ALLOWED'
         STOP
      ENDIF
      IF(INDEX(KEYWRD,'STEP')+INDEX(KEYWRD,'POINTS').NE.0)THEN
         STEP=READA(KEYWRD,INDEX(KEYWRD,'STEP=')+5)
         NPTS=READA(KEYWRD,INDEX(KEYWRD,'POINT=')+6)
         IF(NPTS.GT.200)THEN
            WRITE(6,'(///,''    ONLY TWO HUNDRED POINTS ALLOWED IN REACT
     1'',''ION COORDINATE'')')
            STOP
         ENDIF
         IF(LPARAM.EQ.1.AND.STEP.LE.0)THEN
            WRITE(6,'(///,''    STEP FOR BOND LENGTH SHOULD BE SET POSIT
     1IVE '',''TO PREVENT TWO ATOMS COLLAPSE'')')
            STOP
         ENDIF
         GO TO 220
      ENDIF
  190 READ(5,'(A)',END=210) LINE
      CALL NUCHAR(LINE,VALUE,NREACT)
      IF(NREACT.EQ.0)GOTO 210
      DO 200 I=1,NREACT
         IJ=IREACT+I
         IF(IJ.GT.200)THEN
            WRITE(6,'(///,''    ONLY TWO HUNDRED POINTS ALLOWED IN REACT
     1ION'','' COORDINATE'')')
            STOP
         ENDIF
         REACT(IJ)=VALUE(I)*CONVRT
         IF(ABS(REACT(IJ)-REACT(IJ-1)).LT.1.D-5)THEN
            DUM1 = REACT(IJ)/CONVRT
            DUM2 = REACT(IJ-1)/CONVRT
            WRITE(6,'(///,'' TWO ADJACENT POINTS ARE IDENTICAL:  '',
     1 F7.3,2X,F7.3,/,'' THIS IS NOT ALLOWED IN A PATH CALCULATION'')')
     2 DUM1,DUM2
            STOP
         ENDIF
  200 CONTINUE
      IREACT=IREACT+NREACT
      GO TO 190
  210 CONTINUE
      DEGREE=1.D0
      IF(LPARAM.GT.1)DEGREE=90.D0/ASIN(1.D0)
      IF(IREACT.LE.1) THEN
         WRITE(6,'(//10X,'' NO POINTS SUPPLIED FOR REACTION PATH'')')
         WRITE(6,'(//10X,'' GEOMETRY AS READ IN IS AS FOLLOWS'')')
         CALL GEOUT(1)
         STOP
      ELSE
         WRITE(6,'(//10X,'' POINTS ON REACTION COORDINATE'')')
         WRITE(6,'(10X,8F8.2)')(REACT(I)*DEGREE,I=1,IREACT)
      ENDIF
      IEND=IREACT+1
      REACT(IEND)=-1.D12
C
C OUTPUT GEOMETRY AS FEEDBACK
C
  220 CALL WRTTXT(6)
      IF(INDEX(KEYWRD,'NOLOG').EQ.0)THEN
         OPEN(UNIT=11, FORM='FORMATTED', STATUS='UNKNOWN',
     +FILE=GETNAM('FOR011'))
         CALL WRTTXT(11)
      ENDIF
      CALL GEOUT(1)
      CALL GMETRY(GEO,COORD)
C
C  IF A POLYMER, EXPAND TO MERS
C
      IF(INDEX(KEYWRD,' MERS').NE.0)CALL MAKPOL(COORD)
      IF (INDEX(KEYWRD,'NOXYZ') .EQ. 0) THEN
         IF(INDEX(KEYWRD,'0SCF').NE.0)THEN
C
C  WRITE OUT CARTESIAN COORDINATES FOR USE AS A DATA-SET
C
            WRITE(6,'(A)')'   GEOMETRY IN CARTESIAN COORDINATE FORMAT'
            CALL WRTTXT(6)
            J=0
            DO 230 I=1,NATOMS
               IF(LABELS(I).NE.99)THEN
                  J=J+1
                  WRITE(6,'(2X,A,3(F19.13,I3))')
     1    ELEMNT(LABELS(I)),(COORD(K,J),1,K=1,3)
               ENDIF
  230       CONTINUE
         ELSE
            WRITE(6,'(//10X,''CARTESIAN COORDINATES '',/)')
            WRITE(6,'(4X,''NO.'',7X,''ATOM'',9X,''X'',
     1  9X,''Y'',9X,''Z'',/)')
            L=0
            DO 240 I=1,NATOMS
               IF(LABELS(I) .EQ. 99.OR.LABELS(I).EQ.107) GOTO 240
               L=L+1
               WRITE(6,'(I6,8X,A2,4X,3F10.4)')
     1  L,ELEMNT(LABELS(I)),(COORD(J,L),J=1,3)
  240       CONTINUE
         ENDIF
      ENDIF
      CALL SYMTRZ(COORD,C,NORBS,NORBS,.FALSE.,.FALSE.)
      WRITE(6,'(//''     MOLECULAR POINT GROUP   :   '',A4)') NAME
      IF(   INDEX(KEYWRD,' XYZ') .NE. 0 )THEN
         IF( NVAR .NE. 0 .AND.
     1 INT.AND.(NDEP .NE. 0 .OR.  NVAR.LT.3*NUMAT-6)) THEN
            IF(NDEP.NE.0)
     1WRITE(6,'(//10X,'' INTERNAL COORDINATES READ IN, AND SYMMETRY''
     2,/10X,'' SPECIFIED, BUT CALCULATION TO BE RUN IN CARTESIAN ''
     3,''COORDINATES'')')
            IF(NVAR.LT.3*NUMAT-6)
     1WRITE(6,'(//10X,'' INTERNAL COORDINATES READ IN, AND'',
     2'' CALCULATION '',/10X,''TO BE RUN IN CARTESIAN COORDINATES, '',
     3/10X,''BUT NOT ALL COORDINATES MARKED FOR OPTIMISATION'')')
            WRITE(6,'(//10X,'' THIS INVOLVES A LOGICALLLY ABSURD CHOICE'
     1',/10X,'' SO THE CALCULATION IS TERMINATED AT THIS POINT'')')
            STOP
         ENDIF
         SUMX=0.D0
         SUMY=0.D0
         SUMZ=0.D0
         DO 250 J=1,NUMAT
            SUMX=SUMX+COORD(1,J)
            SUMY=SUMY+COORD(2,J)
  250    SUMZ=SUMZ+COORD(3,J)
         SUMX=SUMX/NUMAT
         SUMY=SUMY/NUMAT
         SUMZ=SUMZ/NUMAT
         DO 260 J=1,NUMAT
            GEO(1,J)=COORD(1,J)-SUMX
            GEO(2,J)=COORD(2,J)-SUMY
  260    GEO(3,J)=COORD(3,J)-SUMZ
         NA(1)=99
         J=0
         NVAR=0
         DO 280 I=1,NATOMS
            IF(LABELS(I).NE.99)THEN
               J=J+1
               IF(J.EQ.1)THEN
                  K=0
               ELSEIF(J.LT.4)THEN
                  K=MIN(3,I-1)
               ELSE
                  K=3
               ENDIF
               DO 270 L=1,K
                  NVAR=NVAR+1
                  LOC(1,NVAR)=J
                  LOC(2,NVAR)=L
  270          XPARAM(NVAR)=GEO(L,J)
               LABELS(J)=LABELS(I)
            ENDIF
  280    CONTINUE
         NATOMS=NUMAT
      ELSE
         IF(NVAR.EQ.0) RETURN
         IF( .NOT. INT.AND.(NDEP .NE. 0 .OR.  NVAR.LT.3*NUMAT-6)) THEN
            IF(NDEP.NE.0)
     1WRITE(6,'(//10X,'' CARTESIAN COORDINATES READ IN, AND SYMMETRY''
     2,/10X,'' SPECIFIED, BUT CALCULATION TO BE RUN IN INTERNAL ''
     3,''COORDINATES'')')
            IF(NVAR.LT.3*NUMAT-6)
     1WRITE(6,'(//10X,'' CARTESIAN COORDINATES READ IN, AND'',
     2'' CALCULATION '',/10X,''TO BE RUN IN INTERNAL COORDINATES, '',
     3/10X,''BUT NOT ALL COORDINATES MARKED FOR OPTIMISATION'')')
            WRITE(6,'(//10X,''MOPAC, BY DEFAULT, USES INTERNAL COORDINAT
     1ES'',/10X,''TO SPECIFY CARTESIAN COORDINATES USE KEY-WORD :XYZ:'')
     2')
            WRITE(6,'(10X,''YOUR CURRENT CHOICE OF KEY-WORDS INVOLVES''
     1,'' A LOGICALLLY'',/10X,''ABSURD CHOICE SO THE CALCULATION IS'',
     2'' TERMINATED AT THIS POINT'')')
            STOP
         ENDIF
      ENDIF
      RETURN
      END


      subroutine get_acars_afwa(i4time_sys,i4_acars_window
     1                                    ,NX_L,NY_L
     1                                    ,ext
     1                                    ,filename,istatus)

      character*(*) filename,ext

!.............................................................................

      character*6 C6_A1ACID
      character*9 a9_timeObs,a9_recptTime
!     character*7 c7_skycover
      real lat_a(NX_L,NY_L)
      real lon_a(NX_L,NY_L)
      real topo_a(NX_L,NY_L)
      real latitude,longitude

!............................................................................

      lun_in = 21

      open(lun_in,file=filename,status='old')

      i = 0

      do while (.true.)

          read(lun_in,101,err=890,end=999) !    NAME          UNITS & FACTOR
     1         I_A1CYCC,
     1         I_A1TYPE,
     1         I_A1DPD,
     1         I_A1GWC,
     1         I_A1JUL,                ! JULIAN HOUR          HR since 673650000
     1         I_A1MIN,                ! TIME-REPORT-MINUTES
     1         I_A1LAT,                ! LATITUDE             DEG * 100
     1         I_A1LON,                ! LONGITUDE            DEG * -100
     1         I_A1KIND,
     1         I_A1ALT,                ! FLIGHT-ALT (pressure) Meters MSL
     1         I_A1PLA,
     1         I_A1DVAL,
     1         I_A1HOLM,
     1         I_A1FLTP,               ! TEMPERATURE          KELVINS * 10
     1         I_A1WD,                 ! WIND-DIRECTION       DEG
     1         I_A1WFLS,               ! WIND-SPEED           M/S * 10
     1         C6_A1ACID
 101      format(16(i9,2x),a6)

          i = i + 1

          write(6,*)
          write(6,*)' acars #',i

          latitude  =  float(I_A1LAT)/100.
          longitude = +float(I_A1LON)/100.
          altitude  =  I_A1ALT

!         write(6,*)' location = '
!    1             ,latitude,longitude,altitude

!         if(latitude  .le. rnorth .and. latitude  .ge. south .and.
!    1       longitude .ge. west   .and. longitude .le. east
!    1                                                             )then
!             continue
!         else ! Outside lat/lon perimeter - reject
!             write(6,*)' lat/lon - reject'
!!   1                 ,latitude,longitude
!             goto 900
!         endif

          if(altitude .gt. 20000.)then
              write(6,*)' Altitude is suspect - reject',altitude
              goto 900
          endif

!         if(abs(timeObs)      .lt. 3d9       .and.
!    1       abs(timereceived) .lt. 3d9              )then
!             call c_time2fname(nint(timeObs),a9_timeObs)
!             call c_time2fname(nint(timereceived),a9_recptTime)
!         else
!             write(6,*)' Bad observation time - reject'
!    1                   ,timeObs,timereceived
!             goto 900
!         endif

          call afwa_julhr_i4time(I_A1JUL,I_A1MIN,i4time_ob)

          call make_fnam_lp(i4time_ob,a9_timeObs,istatus)
          if(istatus .ne. 1)goto900

          a9_recptTime = '         '

!         call cv_asc_i4time(a9_timeObs,i4time_ob)

          i4_resid = abs(i4time_ob - i4time_sys)
          if(i4_resid .gt. i4_acars_window)then ! outside time window
              write(6,*)' time - reject '
     1           ,a9_timeObs,i4_resid,i4_acars_window
              goto 900
          endif

          call open_ext(31,i4time_sys,ext(1:3),istatus)

          write(6,1)a9_timeObs,a9_recptTime
          write(31,1)a9_timeObs,a9_recptTime
 1        format(' Time - prp/rcvd:'/1x,a9,2x,a9)

          write(6,2)latitude,longitude,altitude
          write(31,2)latitude,longitude,altitude
 2        format(' Lat, lon, altitude'/f8.3,f10.3,f8.0)

!         Test for bad winds
!         if(char(dataDescriptor) .eq. 'X')then
!           if(char(errorType) .eq. 'W' .or.
!    1         char(errorType) .eq. 'B'                         )then
!             write(6,*)' QC flag is bad - reject '
!    1                 ,char(dataDescriptor),char(errorType)
!             goto 850
!           endif
!         endif

          windSpeed = float(I_A1WFLS) / 10.
          windDIR = I_A1WD

          if(abs(windSpeed) .gt. 250. .or. windDir .gt. 360.)then
              write(6,*)' wind is suspect - reject',windDir,windSpeed

          else ! write out valid wind
              write(6,3)int(windDir),windSpeed
              write(31,3)int(windDir),windSpeed
 3            format(' Wind:'/' ', i3, ' deg @ ', f6.1, ' m/s')

          endif

          temperature = float(I_A1FLTP)/10.

 850      if(abs(temperature) .lt. 400.)then
              write(6,13)temperature
              write(31,13)temperature
 13           format(' Temp:'/1x,f10.1)

          else
              write(6,*)' Temperature is suspect - reject'
     1                , temperature

          endif

!         if(waterVaporMR .ge. 0. .and.
!    1       waterVaporMR .le. 100.)then
!             write(6,23)waterVaporMR
!             write(31,23)waterVaporMR
!23           format(' MixR:'/1x,f10.3)

!         else
!             write(6,*)' water vapor rejected: ',waterVaporMR
!
!         endif

          go to 900

 890      write(6,*)' Warning: read error'

 900  enddo ! read line of AFWA file

!............................................................................

 999  write(6,*)' End of AFWA file detected'

!     close(lun_in)
      istatus = 1
      return
      end


PROGRAM POlYMERIZE_PEO

  IMPLICIT NONE
  CHARACTER(LEN=5) :: RESNAME,POL_NC
  REAL :: ID0, ID1
  INTEGER :: POL_N, TOT_ATOM, I, CHGROUP, ATOM

  OPEN(Unit=10,File='conf.gro',STATUS='NEW')

  PRINT*, "This program makes a chain of Polyethyl oxide."
  PRINT*, "How many do you want to polymerize?"
  PRINT*, "Must be integer!!"

  READ(*,"(I)") POL_N
  TOT_ATOM = (POL_N-1)*7+(8*2)

  WRITE(10,"(A5,I)") "PEO_N",POL_N
  WRITE(10,"(I5)") TOT_ATOM

  ATOM = 0
  ID0 = 0.903D0
  ID1 = 1.258D0
  CHGROUP = 0

  DO
    CHGROUP = CHGROUP + 1

    IF(CHGROUP == 1) THEN
      RESNAME = "PEOB "
      WRITE(10,902) CHGROUP,RESNAME,"   C2",ATOM+1,"   0.545   1.138   1.100"
      WRITE(10,902) CHGROUP,RESNAME,"  H21",ATOM+2,"   0.539   1.201   1.011"
      WRITE(10,902) CHGROUP,RESNAME,"  H22",ATOM+3,"   0.539   1.201   1.189"
      WRITE(10,902) CHGROUP,RESNAME,"  H23",ATOM+4,"   0.457   1.073   1.100"
      WRITE(10,902) CHGROUP,RESNAME,"    O",ATOM+5,"   0.663   1.060   1.100"
      WRITE(10,902) CHGROUP,RESNAME,"   C1",ATOM+6,"   0.781   1.139   1.100"
      WRITE(10,902) CHGROUP,RESNAME,"  H11",ATOM+7,"   0.782   1.204   1.012"
      WRITE(10,902) CHGROUP,RESNAME,"  H12",ATOM+8,"   0.782   1.204   1.188"
      ATOM = ATOM + 8
      CYCLE
    ENDIF

    IF(CHGROUP == (POL_N + 1)) THEN
      RESNAME = "PEOE "
      IF(MOD(CHGROUP,2) == 0) THEN
        WRITE(10,903) CHGROUP,RESNAME,"   C2",ATOM+1,ID0,"   1.048   1.100"
        WRITE(10,903) CHGROUP,RESNAME,"  H21",ATOM+2,ID0-0.002D0,"   0.983   1.188"
        WRITE(10,903) CHGROUP,RESNAME,"  H22",ATOM+3,ID0-0.002D0,"   0.983   1.012"
        WRITE(10,903) CHGROUP,RESNAME,"    O",ATOM+4,ID0+0.119D0,"   1.126   1.100"
        WRITE(10,903) CHGROUP,RESNAME,"   C1",ATOM+5,ID0+0.237D0,"   1.047   1.100"
        WRITE(10,903) CHGROUP,RESNAME,"  H11",ATOM+6,ID0+0.239D0,"   0.983   1.188"
        WRITE(10,903) CHGROUP,RESNAME,"  H12",ATOM+7,ID0+0.239D0,"   0.983   1.012"
        WRITE(10,903) CHGROUP,RESNAME,"  H13",ATOM+8,ID1-0.027D0,"   1.112   1.100"
        WRITE(10,904) ID1+1.0D0,ID1+1.0D0,ID1+1.0D0
        ELSE
          WRITE(10,903) CHGROUP,RESNAME,"   C2",ATOM+1,ID1,"   1.126   1.100"
          WRITE(10,903) CHGROUP,RESNAME,"  H21",ATOM+2,ID1-0.006D0,"   1.189   1.011"
          WRITE(10,903) CHGROUP,RESNAME,"  H22",ATOM+3,ID1-0.006D0,"   1.189   1.189"
          WRITE(10,903) CHGROUP,RESNAME,"    O",ATOM+4,ID1+0.118D0,"   1.048   1.100"
          WRITE(10,903) CHGROUP,RESNAME,"   C1",ATOM+5,ID1+0.236D0,"   1.127   1.100"
          WRITE(10,903) CHGROUP,RESNAME,"  H11",ATOM+6,ID1+0.237D0,"   1.192   1.012"
          WRITE(10,903) CHGROUP,RESNAME,"  H12",ATOM+7,ID1+0.237D0,"   1.192   1.188"
          WRITE(10,903) CHGROUP,RESNAME,"  H13",ATOM+8,ID0-0.027D0,"   1.411   1.100"
          WRITE(10,904) ID0+1.0D0,ID0+1.0D0,ID0+1.0D0
      ENDIF
      CLOSE(10)
      PRINT*, "RPGORAM Finish!"
      STOP
    ENDIF

    IF((CHGROUP /= 1 ) .or. (CHGROUP /= (POL_N + 1))) THEN
      RESNAME = "PEO  "
      IF(MOD(CHGROUP,2) == 0) THEN
        WRITE(10,903) CHGROUP,RESNAME,"   C2",ATOM+1,ID0,"   1.048   1.100"
        WRITE(10,903) CHGROUP,RESNAME,"  H21",ATOM+2,ID0-0.002D0,"   0.983   1.188"
        WRITE(10,903) CHGROUP,RESNAME,"  H22",ATOM+3,ID0-0.002D0,"   0.983   1.012"
        WRITE(10,903) CHGROUP,RESNAME,"    O",ATOM+4,ID0+0.119D0,"   1.126   1.100"
        WRITE(10,903) CHGROUP,RESNAME,"   C1",ATOM+5,ID0+0.237D0,"   1.047   1.100"
        WRITE(10,903) CHGROUP,RESNAME,"  H11",ATOM+6,ID0+0.239D0,"   0.983   1.188"
        WRITE(10,903) CHGROUP,RESNAME,"  H12",ATOM+7,ID0+0.239D0,"   0.983   1.012"
        ID0 = ID0 + 0.709D0
        ELSE
          WRITE(10,903) CHGROUP,RESNAME,"   C2",ATOM+1,ID1,"   1.126   1.100"
          WRITE(10,903) CHGROUP,RESNAME,"  H21",ATOM+2,ID1-0.006D0,"   1.189   1.011"
          WRITE(10,903) CHGROUP,RESNAME,"  H22",ATOM+3,ID1-0.006D0,"   1.189   1.189"
          WRITE(10,903) CHGROUP,RESNAME,"    O",ATOM+4,ID1+0.118D0,"   1.048   1.100"
          WRITE(10,903) CHGROUP,RESNAME,"   C1",ATOM+5,ID1+0.236D0,"   1.127   1.100"
          WRITE(10,903) CHGROUP,RESNAME,"  H11",ATOM+6,ID1+0.237D0,"   1.192   1.012"
          WRITE(10,903) CHGROUP,RESNAME,"  H12",ATOM+7,ID1+0.237D0,"   1.192   1.188"
          ID1 = ID1 + 0.709D0
      ENDIF
      ATOM = ATOM + 7
      CYCLE
    ENDIF

    PRINT*, "ERROR!!1"
  ENDDO

! READ FORMAT
901 FORMAT(i5,2a5,i5,3f8.3,3f8.4)
! WRITE FORMAT for PEOB
902 FORMAT(i5,2a5,i5,a24)
! WRITE FORMAT for PEO
903 FORMAT(i5,2a5,i5,f8.3,a16)
904 FORMAT(3f8.3)

END PROGRAM