C+
C  MCS Fortran user contributed library.
C
C Purpose:
C   Implement some simplified call to the native MCS functions and subroutines
C   passing relevant info into common blocks (see "mcs_usrlib.inc").
C
C Note:
C   printTable and printValues subroutines are demo versions and require the
C   user to customize them as needed.
C
C Modification history:
C  24/06/2010: v. 0.1c
C              Added DIF specific functions.
C  26/01/2015: v. 0.1d
C              FieldInfo and printValues updated.
C
C LN @ IASF-INAF Feb. 2007                      Last change: 06/12/2014
C-
      INCLUDE 'mcs_fortran.inc'


C. DBConnect: connection to the server "host".
C. Returns 1 if OK.

      INTEGER   FUNCTION DBConnect(host)
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      CHARACTER*(*) host
      INTEGER   l, LENSTR
C-- Only manage some of the MCS types + unsigned int/long
      DATA mcs_types /TINY, SMALL, MEDIUM, INT, BIGINT, FLOAT,
     .                DOUBLE, STRING, TIME, TINY_BLOB, BLOB,
     .                POINTER, 20, 21/
c      DATA mcs_types /0,1,2,3,4,5,6,7,8,9,10,11,20,21/

C-- Some initializations
c      IF (host(1:1).EQ.' ') THEN
      IF (LENSTR(host).NE.0) THEN
        c_host = host
      ELSE
        c_host = 'localhost'
      ENDIF
      n_fields = 0
      n_rows = 0
      null = ifd_null()
      dbc = new_DBConn(null)

c      WRITE(6,'("Connecting...")')
      CALL DBConn_connect(dbc, c_user, c_password, c_dbname, c_host)
c      WRITE(6,*) "DB connection is open: ", DBConn_isOpen(dbc)

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

      DBConnect = 1
      RETURN
      END


C. DBFree: close connection and free resources.

      SUBROUTINE DBFree
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'

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

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

      RETURN
      END


C+ DBExec_qry: connection to the server and query execution.
C. Also sets "n_rows".
C- Returns 1 if OK.

      INTEGER   FUNCTION DBExec_qry(host)
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      CHARACTER*(*) host
      INTEGER   LENSTR, DBConnect

      DBExec_qry = 0

      IF (DBConnect(host).EQ.0) THEN
        WRITE(6,'("Could not connect.")')
        RETURN
      END IF

c      IF (c_query(1:1).EQ.' ') THEN
      IF (LENSTR(c_query).EQ.0) THEN
        WRITE(6,'("Empty query string.")')
        RETURN
      END IF
c      c_query(l:l) = CHAR(0)
      dbq = new_Query( null, dbc, 0 )
      CALL Query_prepare( dbq, c_query )
      CALL Query_execute( dbq, 1 )

      IF (ifd_got_error() .eq. 1) THEN
        WRITE(6,*) ifd_last_error()
        RETURN
      END IF

      n_rows = RecordSet_nRows( dbq )
      DBExec_qry = 1
      RETURN
      END


C+ FieldNames:
C.  set of query field names "f_name" and type "f_itype". Also sets "n_fields".
C-  Returns 1 if OK.
      INTEGER   FUNCTION FieldNames()
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      INTEGER   i, t, is_uns
      INTeger*4 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


C+ FieldInfo:
C.  as FieldNames but also set "n_rows", "f_atype" (fields type description)
C-  and, if the (integer) input parameter is 1 then print an info table.
      SUBROUTINE FieldInfo( info )
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      INTEGER   FieldNames, info, i, idummy
      INTeger*4 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.STRING) THEN
          f_atype(i+1) = 'CHARACTER*(*)'
        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


C+ printTable: print query result using string format for all the fields.
C.
C- Note: that this is just a DEMO as used format could not be adequate.

      SUBROUTINE printTable()
      IMPLICIT NONE

      INCLUDE 'mcs_usrlib.inc'
      INTEGER   i, FieldNames
      INTeger*4 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


C+ printvalues: print query result using the intrinsic data format.
C.
C- Note that this is just a DEMO as used format could not be adequate.

      SUBROUTINE printValues()
      IMPLICIT NONE

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

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(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
            WRITE(6, '(A15, 2X, $)') Data_sval(d)
          ELSE IF (f_itype(i+1).LE.mcs_types(9)) THEN
            WRITE(6, '(A15, 2X, $)') Data_sval(d)
          ELSE IF (f_itype(i+1).LE.mcs_types(10)) THEN
            WRITE(6, '(A, 2X, $)') Data_sval(d)
          ELSE IF (f_itype(i+1).LE.mcs_types(11)) THEN
            WRITE(6, '(A, 2X, $)') Data_sval(d)
          ELSE IF (f_itype(i+1).LE.mcs_types(12)) THEN
            lval = Data_ulval(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
            WRITE(6, '(A15, 2X, $)') Data_sval(d)
          ENDIF
   20   CONTINUE
        WRITE(6,'("")')
        dummy = RecordSet_setNext(dbq)
      ENDDO

      RETURN
      END


C+ LENSTR: length of a string excluding trailing blanks.
C.
C.  Parameters
C.    i str...The string to process
C-

      INTEGER   FUNCTION LENSTR( str )
      IMPLICIT NONE
      INTEGER   length, l
      CHARACTER str*(*),chr*1

      length = LEN( str )
      DO 10 l = length,1,-1
        chr = str(l:l)
        IF (chr.NE.' ' .AND. chr.NE.CHAR(0)) THEN
          lenstr = l
          RETURN
        ENDIF
   10 CONTINUE

      lenstr = l
      RETURN
      END

C+ HTMQRY: DIF (v. > 0.5.2) specific function.
C.         Build query string for a circular or square region on HTM indexing.
C.
C.  Parameters
C.    i coords....The string with coordinates and rad./side ("ra,dec,rad")
C.    i catN......The catalogue name
C.    i is_circle.If > 0 then query a circle/cone else a square
C-

      CHARACTER*(*) FUNCTION difhtmqry(coords, catN, is_circle)
      IMPLICIT NONE

      CHARACTER*(*) coords, catN
      CHARACTER*256 qry

      integer is_circle
      INTEGER  LENSTR
      CHARACTER*12 dif_circ
      CHARACTER*10 dif_rect

      DATA dif_circ /' DIF_Circle('/,
     .     dif_rect /' DIF_Rect('/

      qry = 'SELECT * FROM '// catN(1:LENSTR(catN)) //'_htm WHERE '
      IF (is_circle .GT. 0) THEN
        qry = qry(1:LENSTR(qry)) // dif_circ
      ELSE
        qry = qry(1:LENSTR(qry)) // dif_rect
      ENDIF
      difhtmqry = qry(1:LENSTR(qry)) // coords(1:LENSTR(coords)) //')'

      RETURN
      END
