C+
C     This is a stand-alone demo version and is configured to work
C     on 64-bit machines (see INTeger*8 definition lines).
C     Use the "mcs_fdemos" suite for a more complete reference!
C
C LN @ IASF-INAF Feb. 2007                      Last change: 26/10/2009
C-

      INCLUDE 'mcs_fortran.inc'

      INTEGER FUNCTION DBCONNECT()
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
c      INTEGER*4 Types_TINY,Types_SMALL,Types_MEDIUM,Types_INT,
c     .          Types_BIGINT,Types_FLOAT,Types_DOUBLE,Types_STRING,
c     .          Types_TIME,Types_TINY_BLOB,Types_BLOB

C-- Only manage some of the MCS types
c      DATA mcs_types /Types_TINY(), Types_SMALL(), Types_MEDIUM(),
c     .                Types_INT(), Types_BIGINT(), Types_FLOAT(),
c     .                Types_DOUBLE(), Types_STRING(),
c     .                Types_TIME(), Types_TINY_BLOB(), Types_BLOB()/
      DATA mcs_types /0,1,2,3,4,5,6,7,8,9,10,11,20,21/


      null = ifd_null()

      dbc = new_DBConn(null)
      WRITE(*,*) "Connecting..."
      CALL DBConn_connect(dbc, c_user,c_password,c_dbname, 'localhost')

      WRITE(*,*) "DB connection is open: ", DBConn_isOpen(dbc)

      IF (ifd_got_error() .eq. 1) THEN
        WRITE(*,*) ifd_last_error()
        dbconnect = 0
        RETURN
      END IF

      dbconnect = 1
      RETURN
      END


      SUBROUTINE DBFREE
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'

      CALL Query_close(dbq)
      IF (ifd_got_error() .eq. 1) THEN
        WRITE(*,*) ifd_last_error()
      END IF

      CALL ifd_reset_error()
      CALL del_Query(dbq)
      CALL ifd_reset_error()
      CALL del_DBConn(dbc)

      RETURN
      END

      INTEGER FUNCTION DBEXEC_QRY()
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'

      dbc = new_DBConn( ifd_null() )
      WRITE(*,*) "Connecting...\n"
      CALL DBConn_connect(dbc, c_user,c_password,c_dbname, 'localhost')
      IF (ifd_got_error() .eq. 1) THEN
        WRITE(*,*) ifd_last_error()
        dbexec_qry = 0
        RETURN
      END IF

      dbq = new_Query( ifd_null(), dbc, 0 )
      CALL Query_prepare( dbq, c_query )
      CALL Query_execute( dbq, 1 )

      IF (ifd_got_error() .eq. 1) THEN
        WRITE(*,*) ifd_last_error()
        dbexec_qry = 0
        RETURN
      END IF

      RETURN
      END


      INTEGER FUNCTION FieldNames()
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      INTEGER   i, t, is_uns
      INTeger*8 dummy, vec, d

      n_fields = RecordSet_nFields( dbq )
      IF (ifd_got_error().EQ.1 .OR. n_fields.EQ.0) THEN
        WRITE(6,*) ifd_last_error()
        FieldNames = 0
        RETURN
      END IF

      vec = RecordSet_metarec( dbq )
      DO 10 i=0, n_fields-1
        d = Record_field( vec, i )
        f_name(i+1) = Data_name( d )
        t = Data_type( d )
        is_uns = Data_isUnsigned( d )
        IF (is_uns.EQ.1) THEN
          IF ((t.EQ.mcs_types(1)) .OR. (t.EQ.mcs_types(2)) .OR.
     .        (t.EQ.mcs_types(3)) .OR. (t.EQ.mcs_types(4))) THEN
            f_itype(i+1) = mcs_types(13)
          ELSE
            f_itype(i+1) = mcs_types(14)
          END IF
        ELSE
          f_itype(i+1) = t
        END IF

   10 CONTINUE

      FieldNames = 1
      RETURN
      END



      SUBROUTINE FieldInfo( info )
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      INTEGER   FieldNames, info, i, idummy
      INTeger*8 vec, d


      idummy = FieldNames()
      n_rows = RecordSet_nRows( dbq )

      DO 10 i=0, n_fields-1
        IF (f_itype(i+1).LE.SMALL) THEN
          f_atype(i+1) = 'INTEGER*2'
        ELSE IF (f_itype(i+1).LE.INT) THEN
          f_atype(i+1) = 'INTEGER*4'
        ELSE IF (f_itype(i+1).LE.BIGINT) THEN
          f_atype(i+1) = 'INTEGER*8'
        ELSE IF (f_itype(i+1).EQ.FLOAT) THEN
          f_atype(i+1) = 'REAL*4'
        ELSE IF (f_itype(i+1).EQ.DOUBLE) THEN
          f_atype(i+1) = 'REAL*8'
        ELSE IF (f_itype(i+1).EQ.TIME) THEN
          f_atype(i+1) = 'INTEGER*8 (DATETIME)'
        ELSE IF (f_itype(i+1).EQ.TINY_BLOB) THEN
          f_atype(i+1) = 'BYTE (TINYBLOB)'
        ELSE IF (f_itype(i+1).EQ.BLOB) THEN
          f_atype(i+1) = 'BYTE (BLOB)'
        ELSE IF (f_itype(i+1).EQ.POINTER) THEN
          f_atype(i+1) = 'INTEGER (POINTER)'
        ELSE IF (f_itype(i+1).EQ.20) THEN
          f_atype(i+1) = 'INTEGER*4 (UNSIGNED)'
        ELSE IF (f_itype(i+1).EQ.21) THEN
          f_atype(i+1) = 'INTEGER*8 (UNSIGNED)'
        ELSE
          f_atype(i+1) = 'UNDEF'
        END IF
   10 CONTINUE


      IF (info.GT.0) THEN
        WRITE(6,1) n_fields, n_rows
   1  FORMAT('Info on the query returned table:'/,
     .        'Nr of fields: ',I3,'  Nr of rows: ',I6/, 'Field names:')
        DO 20 i=1, n_fields
          WRITE(6,2) f_name(i), f_itype(i), f_atype(i)
   2  FORMAT(A,'Type ID: ',I2,'  Type desc.:',A)
   20   CONTINUE
      END IF
      WRITE(6,'("")')

      RETURN
      END



      SUBROUTINE printTable()
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      INTEGER   i, FieldNames
      INTeger*8 dummy, vec, d


C- Print head
      dummy = FieldNames()
      if (dummy.EQ.0) RETURN

      DO 10 i=1, n_fields
   10 WRITE(6, '(A16, 4X, $)') f_name(i)
      WRITE(6,'(/"---")')

C- Print data as string values
      dummy = RecordSet_setFirst(dbq)
      DO WHILE (RecordSet_eof(dbq).EQ.0)
        vec = RecordSet_rec(dbq)
        DO 20 i=0, n_fields-1
           d = Record_field(vec, i)
           WRITE(6, '(A15, 2X, $)') Data_sval(d)
   20   CONTINUE
        WRITE(6,'("")')
        dummy = RecordSet_setNext(dbq)
      ENDDO

      RETURN
      END



      SUBROUTINE printValues()
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      INTEGER*2 ival
      INTEGER   i, lval, FieldNames
      INTeger*8 dummy, vec, d
      REAL*4 fval
      REAL*8 dval
      CHARACTER*64 sval

C- Print head
      dummy = FieldNames()
      if (dummy.EQ.0) RETURN

      DO 10 i=1, n_fields
   10 WRITE(6, '(A16, 4X, $)') f_name(i)
      WRITE(6,'("")')

C- Print data as string values
      dummy = RecordSet_setFirst(dbq)
      DO WHILE (RecordSet_eof(dbq).EQ.0)
        vec = RecordSet_rec(dbq)
        DO 20 i=0, n_fields-1
          d = Record_field(vec, i)
C- Discriminate types: integer, unsigned, float, double, string
          IF (f_itype(i+1).LE.mcs_types(2)) THEN
            ival = Data_ival(d)
            WRITE(6, '(I10, 2X, $)') ival
          ELSE IF (f_itype(i+1).LE.mcs_types(5)) THEN
            lval = Data_lval(d)
            WRITE(6, '(I10, 2X, $)') lval
          ELSE IF (f_itype(i+1).LE.mcs_types(13)) THEN
            lval = Data_uival(d)
            WRITE(6, '(I10, 2X, $)') lval
          ELSE IF (f_itype(i+1).LE.mcs_types(14)) THEN
            lval = Data_ulval(d)
            WRITE(6, '(I10, 2X, $)') lval
          ELSE IF (f_itype(i+1).LE.mcs_types(6)) THEN
            fval = Data_fval(d)
            WRITE(6, '(G12.6, 2X, $)') fval
          ELSE IF (f_itype(i+1).LE.mcs_types(7)) THEN
            dval = Data_dval(d)
            WRITE(6, '(G12.6, 2X, $)') dval
          ELSE IF (f_itype(i+1).LE.mcs_types(8)) THEN
            sval = Data_sval(d)
            WRITE(6, '(A15, 2X, $)') sval
          ELSE
            WRITE(6, '(A15, 2X, $)') Data_sval(d)
          ENDIF
   20   CONTINUE
        WRITE(6,'("")')
        dummy = RecordSet_setNext(dbq)
      ENDDO

      RETURN
      END



      PROGRAM MCSDEMO
      IMPLICIT NONE
c     INCLUDE 'mcs_facility.inc'

      INCLUDE 'mcs_usrlib.inc'
      INTEGER*8 status, l, DBEXEC_QRY
      CHARACTER*200 qry

      DATA c_user /'mpe'/, c_password /'mpe2014pass'/,
     .     c_dbname /'mpe2014'/,
     .     c_query /'SELECT * FROM UCAC_2orig WHERE((htmID_6=31594 OR
     . htmID_6=64369) AND (RAcs>3568075 AND RAcs<3631925)
     . AND (DECcs>7170000 AND DECcs<7230000))'/
c     .     c_query /'SELECT htmID,GSChtm FROM TOCats.regions'/

      CALL GETARG( 1, qry )
      IF (qry.NE.' ') c_query=qry

      l = INDEX(c_user," ")
      c_user(l:l) = CHAR(0)
      l = INDEX(c_password," ")
      c_password(l:l) = CHAR(0)
      l = INDEX(c_dbname," ")
      c_dbname(l:l) = CHAR(0)
      status = dbexec_qry()

      CALL fieldinfo(1)

      CALL printValues()

      CALL dbfree
      END
