76 lines
3.3 KiB
Fortran
76 lines
3.3 KiB
Fortran
SUBROUTINE DB_INFO ( dbinfo, iret )
|
|
C************************************************************************
|
|
C* DB_INFO *
|
|
C* *
|
|
C* This subroutine puts DB info into common. *
|
|
C* *
|
|
C* DB_INFO ( DBINFO, IRET ) *
|
|
C* *
|
|
C* Input parameters: *
|
|
C* DBINFO CHAR* DB info *
|
|
C* *
|
|
C* Output parameters: *
|
|
C* IRET INTEGER Return code *
|
|
C* 0 = normal return *
|
|
C* -14 = could not set db def parms*
|
|
C** *
|
|
C* Log: *
|
|
C* m.gamazaychikov/CWS 07/09 *
|
|
C* m.gamazaychikov/CWS 02/11 Removed setting the dbhost *
|
|
C************************************************************************
|
|
INCLUDE 'GEMPRM.PRM'
|
|
INCLUDE 'dbcmn.cmn'
|
|
C*
|
|
CHARACTER*(*) dbinfo
|
|
C*
|
|
CHARACTER sourc*6, parms*5, pfile*4
|
|
CHARACTER carr(5)*128, carr2(2)*80, sprtr*2
|
|
DATA sourc / 'SOURCE' /
|
|
DATA parms / 'PARMS' /
|
|
DATA pfile / 'FILE' /
|
|
DATA sprtr / '--' /
|
|
LOGICAL issource, isparms, isfile
|
|
C------------------------------------------------------------------------
|
|
DO ii = 1, 2
|
|
carr(ii) = ' '
|
|
carr2(ii) = ' '
|
|
END DO
|
|
dbdatasrc = ' '
|
|
dbparms = ' '
|
|
dbprmfile = ' '
|
|
issource = .false.
|
|
isparms = .false.
|
|
isfile = .false.
|
|
CALL ST_CLS2 ( dbinfo, '|', '--', 5, carr, num, ier )
|
|
C
|
|
C* Match alias with its attribute list.
|
|
C
|
|
DO icarr = 2, num
|
|
IF ( carr(icarr) .ne. sprtr ) THEN
|
|
CALL ST_CLS2 ( carr(icarr), ':', ' ', 2, carr2,
|
|
+ num2, ier )
|
|
IF ( num2 .eq. 2 ) THEN
|
|
CALL ST_LSTR ( carr2(1), ilstr1, ier )
|
|
CALL ST_LSTR ( carr2(2), ilstr2, ier )
|
|
IF (carr2(1)(:ilstr1) .eq. sourc) THEN
|
|
dbdatasrc = carr2(2)(1:ilstr2)
|
|
issource = .true.
|
|
ELSE IF (carr2(1)(:ilstr1) .eq. parms) THEN
|
|
dbparms = carr2(2)(1:ilstr2)
|
|
isparms = .true.
|
|
ELSE IF (carr2(1)(:ilstr1) .eq. pfile) THEN
|
|
dbprmfile = carr2(2)(1:ilstr2)
|
|
isfile = .true.
|
|
END IF
|
|
END IF
|
|
END IF
|
|
END DO
|
|
|
|
IF ( .not. issource .or. .not. isparms .or. .not. isfile ) THEN
|
|
iret = -14
|
|
CALL ER_WMSG ( 'DB', iret, ' ', ier )
|
|
RETURN
|
|
END IF
|
|
C*
|
|
RETURN
|
|
END
|