C Copyright 1995, Columbia University, all rights reserved.
C Permission is granted to utilize and disseminate this code or
C  document without charge, provided that (1) this copyright notice is 
C  not removed, and (2) all changes made by other than members of the 
C  MacroModel Development Group at Columbia University are, if further 
C  disseminated, (a) noted as such; for example, by means of source-code 
C  comment lines, and (b) communicated back to the author for possible 
C  inclusion in subsequent versions.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C *** $RCSfile: fmmio.f,v $
C *** $Revision: 1.8 $
C *** $Date: 1996/01/24 16:43:51 $
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C fmmio: read mmod files from input and copy them to output.
C Usage: fmmio [-cf]  
C if the "-f" option is given, always write full CTs on output even if 
C  compressed CTs are present in input.  This is the default, and
C  will uncompress a compressed mmod file.
C if "-c" is specified, then compressed CTs will be written to the output
C  whenever they appear in the input.  This amounts to a copy of the
C  input file.
C fmmio does not compress full CTs.
C fmmio has two purposes: to provide an example of how to use the mmio API,
C  and to make sure that some simple facilities of the mmio library are
C  working correctly. fmmio always gives verbose output, which would not
C  be desirable in a "real" application.

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM FMMIO
C *** Driver for mmio library, FORTRAN API:

      IMPLICIT NONE

      INCLUDE 'mmio.inc'

      CHARACTER*(MMIO_L_STRLEN) READ_FNAME, WRITE_FNAME, STR
      INTEGER NSTR, IARGC, CT_TYPE_REQUESTED, LNSTR
      INTEGER ISTAT, CT_TYPE, ICT, IATOM

      CHARACTER*(MMIO_L_STRLEN) TITLE
      INTEGER NATOM

      INTEGER MMOD_IATOM
      INTEGER ITYPE
      INTEGER NBOND
      INTEGER BOND_ATOM( MMIO_MAXBOND )
      INTEGER BOND_ORDER( MMIO_MAXBOND )
      REAL XYZ( 3 )
      REAL CHARGE1
      REAL CHARGE2
      CHARACTER CHAIN
      INTEGER COLOR
      INTEGER RESNUM
      CHARACTER RESNAME1
      CHARACTER*(MMIO_S_STRLEN) RESNAME4
      CHARACTER*(MMIO_S_STRLEN) PDBNAME
      INTEGER IREAD
      INTEGER IWRITE

C     *** parse cmdline opts, getting file type requested and IO file names:
      CALL GETARG( 1, STR )
      NSTR = IARGC()
      IF( STR(1:1) .EQ. '-' )THEN
        IF( NSTR .NE. 3 )THEN
          CALL USAGE()
          STOP '*** fmmio: ERROR'
        ENDIF
        IF( STR(2:2) .EQ. 'f' )THEN
          CT_TYPE_REQUESTED = MMIO_FULL
        ELSEIF( STR(2:2) .EQ. 'c' )THEN
          CT_TYPE_REQUESTED = MMIO_COMPRESSED
        ENDIF
        CALL GETARG( 2, STR )
        READ_FNAME = STR
        CALL GETARG( 3, STR )
        WRITE_FNAME = STR
      ELSE
        IF( NSTR .NE. 4 )THEN
          CALL USAGE()
          STOP '*** fmmio: ERROR'
        ENDIF
        CT_TYPE_REQUESTED = MMIO_FULL
        READ_FNAME = STR
        CALL GETARG( 2, STR )
        WRITE_FNAME = STR
      ENDIF

C     *** report fnames for reading and writing:
      WRITE( 6, '(A,A,1X,A)' )'fmmio: readfile, writefile= ',
     & READ_FNAME(1:LNSTR(READ_FNAME)),
     & WRITE_FNAME(1:LNSTR(WRITE_FNAME))
        
C     *** set stdout for location of err msgs from library:
      CALL MMIO_ERRFILE( 6 )

C     *** open file for reading:
      CALL MMIO_OPEN( IREAD, READ_FNAME, MMIO_READ, ISTAT )
      CALL MMIO_RETURN_CODE( ISTAT, STR )
      WRITE( 6, '(A,A,A,A)' )'fmmio: MMIO_OPEN returns ',
     & STR(1:LNSTR(STR)), ' for read_file ',
     & READ_FNAME(1:LNSTR(READ_FNAME))
      IF( ISTAT .EQ. MMIO_ERR )STOP '*** fmmio: ERROR'

C     *** open file for writing:
      CALL MMIO_OPEN( IWRITE, WRITE_FNAME, MMIO_WRITE, ISTAT )
      CALL MMIO_RETURN_CODE( ISTAT, STR )
      WRITE( 6, '(A,A,A,A)' )'fmmio: MMIO_OPEN returns ',
     & STR(1:LNSTR(STR)), ' for write_file ',
     & WRITE_FNAME(1:LNSTR(WRITE_FNAME))
      IF( ISTAT .EQ. MMIO_ERR )STOP '*** fmmio: ERROR'

      ICT = 1
10    CONTINUE
C       *** Begin infinite loop, reading CTs, to be exited when we 
C       ***  reach EOF on input:

C       *** Get the next CT header line:
        CALL MMIO_GET_CT( IREAD, CT_TYPE_REQUESTED, NATOM, TITLE,
     &   ISTAT )
        CALL MMIO_RETURN_CODE( ISTAT, STR )
        WRITE( 6, '(A,A,A,I5)' )'fmmio: MMIO_GET_CT returns ',
     &   STR(1:LNSTR(STR)), ' for ict= ', ICT
        IF( ISTAT .EQ. MMIO_ERR )STOP '*** fmmio: ERROR'
        WRITE( 6, '(A,I5,A,A,A,A)' )'  natom, title= ',
     &   NATOM, ', ', '''', TITLE(1:LNSTR(TITLE)), ''''
        IF( ISTAT .EQ. MMIO_EOF )GOTO 20

C       *** Put the header line on output:
        CT_TYPE = ISTAT
        CALL MMIO_PUT_CT( IWRITE, CT_TYPE, NATOM, TITLE, ISTAT )
        CALL MMIO_RETURN_CODE( ISTAT, STR )
        WRITE( 6, '(A,A,A,I5)' )'fmmio: MMIO_PUT_CT returns ',
     &   STR(1:LNSTR(STR)), ' for ict= ', ICT
        IF( ISTAT .EQ. MMIO_ERR )STOP '*** fmmio: ERROR'

C       *** Alternately get and put atom info for each atom;  this
C       ***  interleaving of Get and Put is not a requirement of the
C       ***  mmio library; rather, it was just the most convenient
C       ***  way to write this application:
        DO 30 IATOM = 1, NATOM

C         *** Get:
          CALL MMIO_GET_ATOM( IREAD, MMOD_IATOM, ITYPE, NBOND,
     &     BOND_ATOM, BOND_ORDER, XYZ, CHARGE1, CHARGE2, CHAIN,
     &     COLOR, RESNUM, RESNAME1, RESNAME4, PDBNAME, ISTAT ) 
          CALL MMIO_RETURN_CODE( ISTAT, STR )
          WRITE( 6, '(A,A,A,I5,I5)' )'fmmio: MMIO_GET_ATOM returns ',
     &     STR(1:LNSTR(STR)), ' for iatom, mmio_iatom= ', IATOM,
     &     MMOD_IATOM
          IF( ISTAT .EQ. MMIO_ERR )STOP '*** fmmio: ERROR'

C         *** Put:
          CALL MMIO_PUT_ATOM( IWRITE, MMOD_IATOM, ITYPE, NBOND,
     &     BOND_ATOM, BOND_ORDER, XYZ, CHARGE1, CHARGE2, CHAIN,
     &     COLOR, RESNUM, RESNAME1, RESNAME4, PDBNAME, ISTAT ) 
          CALL MMIO_RETURN_CODE( ISTAT, STR )
          WRITE( 6, '(A,A)' )'fmmio: MMIO_PUT_ATOM returns ',
     &     STR(1:LNSTR(STR))
          IF( ISTAT .EQ. MMIO_ERR )STOP '*** fmmio: ERROR'

30      CONTINUE

C       *** Done with printing this CT; increment CT index:
        ICT = ICT + 1

C       *** Close infinite loop.
      GOTO 10

C     *** Branch here when EOF is found on input:
20    CONTINUE

      WRITE( 6, '(A,I5,A)' )
     & 'fmmio: ', ICT-1, ' CTs found in input file'

C     *** Try MMIO_GET_CT again, just for fun;  should return EOF:
      WRITE( 6, '(A)' )
     & 'fmmio: trying MMIO_GET_CT again; should return EOF:'
      CALL MMIO_GET_CT( IREAD, CT_TYPE_REQUESTED, NATOM, TITLE,
     & ISTAT )
      CALL MMIO_RETURN_CODE( ISTAT, STR )
      WRITE( 6, '(A,A)' )'fmmio: MMIO_GET_CT returns ',
     & STR(1:LNSTR(STR))

C     *** Close input file (not really necessary under UNIX):
      WRITE( 6, '(A)' ) 'fmmio: trying MMIO_CLOSE for readfile'
      CALL MMIO_CLOSE( IREAD, ISTAT )
      CALL MMIO_RETURN_CODE( ISTAT, STR )
      WRITE( 6, '(A,A)' )'fmmio: MMIO_CLOSE returns ',
     & STR(1:LNSTR(STR))

C     *** Close output file (not really necessary under UNIX):
      WRITE( 6, '(A)' ) 'fmmio: trying MMIO_CLOSE for writefile'
      CALL MMIO_CLOSE( IWRITE, ISTAT )
      CALL MMIO_RETURN_CODE( ISTAT, STR )
      WRITE( 6, '(A,A)' )'fmmio: MMIO_CLOSE returns ',
     & STR(1:LNSTR(STR))
      
C     *** tell mmio to free up any allocated storage (not really
C     ***  necessary under UNIX: 
      CALL MMIO_CLEANUP( ISTAT )
      CALL MMIO_RETURN_CODE( ISTAT, STR )
      WRITE( 6, '(A,A)' )'fmmio: MMIO_CLEANUP returns ',
     & STR(1:LNSTR(STR))

C     *** tell the world we've succeeded: 
      WRITE( 6, '(A)' )'fmmio: SUCCESSFUL COMPLETION'
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE USAGE()

      WRITE( 6, '(A)' )'Usage: fmmio [-cf]  '
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER FUNCTION LNSTR( STR )
C *** Function returning the index to the last character in a string which
C ***  is neither a blank nor an ASCII NUL;  NULs sometimes arise
C ***  in C/Fortran string passing.
C *** If string is all blanks or nulls, LNSTR returns 1, not zero;  this
C ***  is to allow calling program to say, for example:
C ***         WRITE( 6, '(A)' ) STR(1:LNSTR(STR))
C *** Original version:  Peter Shenkin, March, 1993

      IMPLICIT NONE 

C     *** dummy vars:
      CHARACTER*(*) STR

C     *** local vars:
      INTEGER I, L

      L = LEN( STR )
      DO 10 I = L, 1, -1
        IF( STR(I:I).NE.' ' .AND. ICHAR(STR(I:I)).NE.0 )THEN
          LNSTR = I
          RETURN
        ENDIF
10    CONTINUE

C     *** we get here only if all chars were either blank or ASCI-NUL:
      STR = ' '
      LNSTR = 1

      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC