CSUBNIJX1 = NIJX1.PC **** Part 1 of the NIJX subroutines C WILPAR ==> DDMAIN dd 7 Oct 97 **** Last Update NIJX2: 8 June 1999 **** Comments / modifications / log **** See CSUBNIJX2 ( :line 200 ) C----------------------------------------------------------------------- **** Computer specific subroutines =======> PC only Update: ... 96 **** for IBM or MSDOS PC, SALFORD FTN77, implem: J.M.M. Smits, 23 Jan.92 **** Note: before compiling, concatenate: NIJX = NIJX1 + NIJX2 !!!!! **** List of subroutines given in this file:===> DATIME, KEYSWI, FILINX **** First record of the general NIJX2 file/routines contains: CSUBNIJX2 CSUBFOR C+---------------------------------------------------------------------- CSUBROUTINE DATIME (I1, I2, I3) C----------------------------------------------------------------------- C Subroutine to get the system date and the CPU time in msec. Output: C I1 time of the day as hhmm (hh=hours, mm=minutes) C I2 CPU time in msec used since initiation C I3 day-number as yynnn (yy=year, nnn=number) C I1 = I2 = I3 = 0 implies that an invalid clock value was returned C by the routine DATIMX (if the time routines have not been disabled). C This subroutine is computer dependent ===== it is not in FORTRAN77 ANS C Subroutine DATIME is only used by the subroutines KEDATE and KETIME . C+---------------------------------------------------------------------- SUBROUTINE DATIME (I1, I2, I3) CHARACTER*8 TIME@, TIMESTR, DATE@, DATESTR DIMENSION L(12) LOGICAL INIT DATA INIT /.FALSE./ DATA L / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / DATA II3 / 0 / IF ( .NOT. INIT ) THEN TIMESTR = TIME@() READ(TIMESTR, 10) IHR, IMIN, ISEC DATESTR = DATE@() READ (DATESTR, 10) IMON, IDAY, IYEAR 10 FORMAT (I2,1X,I2,1X,I2) I1 = IHR*100 + IMIN I2 = 0 I3 = IYEAR CALL CLOCK@ ( START ) ISTART = START * 1000.0 IF ( MOD(I3,4) .EQ. 0 ) L(2) = 29 IDAG = 0 NM = IMON - 1 IF ( NM .NE. 0 ) THEN DO 20 I = 1, NM 20 IDAG = IDAG + L(I) ENDIF I3 = I3*1000 + IDAG + IDAY INIT = .TRUE. C98 SAVE II3 = I3 ELSE TIMESTR = TIME@() READ(TIMESTR, 10) IHR, IMIN, ISEC I1 = IHR*100 + IMIN CALL CLOCK@ ( ELAPS ) IELAPS = ELAPS * 1000.0 I2 = IELAPS - ISTART I3 = II3 ENDIF RETURN C END OF SUBR DATIME END CSUBROUTINE KEYSWI C----------------------------------------------------------------------- C Subr. for 'local' KEYS and SWITCH settings, and 'local' specialities ! C Switches are defaulted .FALSE. and may be changed at any time: C SWITCH(1) = NIJMEG = .TRUE. on execution in Nijmegen: see NIJX1.FORIBM C SWITCH(2) = MOLEN = .TRUE. for MOLEN users: see -------> NIJX1.FORVAX C SWITCH(6) = SWFILX = .TRUE. if subr. FILINX is needed: -> NIJX1.FORCYB C SWITCH(3), SWITCH(4) and SWITCH(5) are still free. C KEYS() are defaulted = 0 and several are still free. C KEYS(11) = 3 to output SPEK parameters by program AT2X (NUTS) C KEYS(11) = IATX = key for output type ATOMS file C KEYS(12) = IFNM = key for file name modification (CAP/CCODE) C KEYSWI is called once at the beginning of each program, and it is C called again at any STOP (including at an error stop). *** Note 1: if you wish us to implement some special private features C for you, please, write to us. These private features then will be C activated by these SWITCHes or KEYS. *** Note 2: you can implement your own routine at the beginning and at C the end of the execution of any program. E.g. see NIJX1.FORCYB. *** Note 3: we will be very happy to help ! C+---------------------------------------------------------------------- SUBROUTINE KEYSWI C ------ /SYSTA/ and /SYSTB/ interface with supervisor. COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH *** LOGICAL SWFILX EQUIVALENCE (IATX, KEYS(11)) LOGICAL FIRST DATA FIRST / .TRUE. / C IATX = 3 to signal that AT2X is to write SPEK parameters 'SPF' C IATX = 5 to include writing of schakal file IF (IATX .EQ. 0) IATX = 5 IF (FIRST) THEN C switch FIRST = .TRUE. for first entry, reset to .FALSE. FIRST = .FALSE. C things to be done at start for each program ELSE FIRST = .TRUE. C things to be done at STOP for each program ENDIF RETURN C END OF SUBROUTINE KEYSWI END CSUBROUTINE FILINX (FNAME) C----------------------------------------------------------------------- C Subroutine for 'local' file definitions. C This subroutine is called prior to opening any file (input or output). C The file name for an input or output file is defaulted by FORTRAN in : C CHARACTER FNAME *64 C The DIRDIF standard is : up to six characters: all letters as CAPITALS C This may be modified to suit your needs, see: C IFNM = Internal File Name Modification C On first entry read environmental parameters: C DIRSYSTEM (path to files DIRDIF.ORBASE, -.ORUSER and -.DDHELP) C DIRTDISK (path to possible RAM drive for temporary files). C If DIRTDISK is defined, add this path to files that are normally C written to the tempry disk. ======== J.M.M. Smits, 22 Jan 1992 C+---------------------------------------------------------------------- SUBROUTINE FILINX (FNAME) CHARACTER *64 FNAME, GNAME, DIRSYSTEM, DIRTDISK C ------ /SYSTA/ and /SYSTB/ interface with supervisor. COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH **** EQUIVALENCE (IFNM, KEYS(12)) C98 KEYS(12) = IFNM = key for file name modification (CAP/CCODE) C IFNM = 0: CAP, 1: lower-case, 2: CCODE.CAP, 3: ccode.lower-case **** test moet nog even wachten COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 LOGICAL FIRST DATA FIRST / .TRUE. / IFNM = 0 IF ( FIRST ) THEN C98===TEMP=======TEST: IFNM = 2 OK but also in .BAT file! C call system particulars CALL DOSPARAM@( 'DIRSYSTEM', DIRSYSTEM ) LDS = LENG( DIRSYSTEM ) CALL DOSPARAM@( 'DIRTDISK', DIRTDISK ) LTD = LENG( DIRTDISK ) FIRST = .FALSE. ENDIF GNAME = FNAME LFN = LENG ( FNAME ) C FILINX: PC, check for global files C98 DDCONFIG added for file dirdif.ddconfig IF ( FNAME .EQ. 'ORBASE' .OR. FNAME .EQ. 'ORUSER' .OR. * FNAME .EQ. 'DDHELP' .OR. FNAME .EQ. 'DDLIC' .OR. * FNAME .EQ. 'DDCON' .OR. FNAME .EQ. 'DDCONFIG') THEN GNAME = DIRSYSTEM(1:LDS) // FNAME(1:LFN) C JMS '92: check for SPF file: write PLUTON (SPEK) parameters ELSEIF ( FNAME .EQ. 'SPF' ) THEN GNAME = CCODE(1:LENG(CCODE)) // '.SPF' C else check for all temporary binary data files ELSEIF ( LTD .NE. 0 .AND. *( ( FNAME(1:3) .EQ. 'BIN' .AND. FNAME .NE. 'BINFO' ) .OR. * FNAME .EQ. 'FMAP' .OR. FNAME .EQ. 'FMAPT' .OR. * FNAME .EQ. 'E100' .OR. FNAME .EQ. 'MFUN' .OR. * FNAME .EQ. 'PDEK' .OR. FNAME .EQ. 'ATTEST' ) ) THEN GNAME = DIRTDISK(1:LTD) // FNAME(1:LFN) **** ELSE .... just like SPF if requested.... by PROFILE C remaining files belong to the compound CCODE, to be saved C98 first FILINX for DDJOB, then PROFIL, then various..... **** test moet nog even wachten C IFNM = Internal File Name Modification * ELSEIF ( IFNM .GE. 2 ) THEN * L = LENG(CCODE) * GNAME = CCODE(1:L) // '.' // FNAME(1:8) *** IF ( FNAME .EQ. 'CRYSIN' ) GNAME = CCODE(1:L) // '.CRY' * IF ( FNAME .EQ. 'CRYSDA' ) GNAME = CCODE(1:L) // '.CRA' *** IF ( FNAME .EQ. 'ATOMS' ) GNAME = CCODE(1:L) // '.ATS' *** IF ( FNAME .EQ. 'ATMOD' ) GNAME = CCODE(1:L) // '.ATM' * IF ( FNAME .EQ. 'ATOLD' ) GNAME = CCODE(1:L) // '.ATX' * IF ( FNAME .EQ. 'ATLIT' ) GNAME = CCODE(1:L) // '.ATL' *** IF ( FNAME .EQ. 'BINFO' ) GNAME = CCODE(1:L) // '.BIN' * IF ( FNAME .EQ. 'LIS1' ) GNAME = CCODE(1:L) // '.LS1' * IF ( FNAME .EQ. 'LIS2' ) GNAME = CCODE(1:L) // '.LS2' C BUT: * IF ( FNAME .EQ. 'DDJOB' .OR. FNAME .EQ. 'DDSYST' ) * * GNAME = FNAME ENDIF FNAME = GNAME RETURN C END OF SUBROUTINE FILINX END