* PACKAGE YSUN !" 機種依存ルーチン for Sun Fortran * *" [HIS] 90/05/19(numaguti) *" 92/06/05(takepiro) *" 93/07/05(takepiro) Sun fortran デバッグ用関数追加 * ********************************************************************* SUBROUTINE ERRTRA !" エラートレースバック * * [INTERNAL WORK] INTEGER IPID, IRET * * [INTRINSIC FUNC] INTEGER GETPID INTEGER KILL * IPID=GETPID() IRET=KILL(IPID,5) * RETURN END ********************************************************************* SUBROUTINE YCLOCP !" CPU時間を出力 I ( HREM ) * * [INPUT] CHARACTER HREM*(*) !" 表題 * * [INTERNAL SAVE] REAL CPUOLD !" 前の呼出の経過時間 REAL VPUOLD !" 前の呼出のユーザ時間 DATA CPUOLD, VPUOLD / 0. , 0. / SAVE * * [INTERNAL WORK] REAL CPUTIM !" 経過時間 REAL VPUTIM !" ユーザ時間 * CALL YCLOCK( CPUTIM, VPUTIM ) WRITE ( 6,9000 ) HREM, CPUTIM - CPUOLD, VPUTIM - VPUOLD, & CPUTIM , VPUTIM 9000 FORMAT( ' ',A8,': CPU/VPU TIME = ', 2E10.5, ' : ', 2E10.5 ) CPUOLD = CPUTIM VPUOLD = VPUTIM * RETURN END ******************************************************************** SUBROUTINE YCLOCK !" CPU時間を与える O ( CPUTIM, VPUTIM ) * * [OUTPUT] REAL CPUTIM !" 経過時間 REAL VPUTIM !" ユーザ時間 * * [INTERNAL SAVE] REAL TICKS REAL TICK0, TUSR0 !" スタート DATA TICK0, TUSR0 / 0. , 0. / SAVE * * [INTERNAL WORK] REAL*4 TARRAY( 2 ) * * [INTRINSIC FUNC] REAL*4 ETIME * TICKS = ETIME( TARRAY ) CPUTIM = TICKS - TICK0 VPUTIM = TARRAY( 1 ) - TUSR0 * RETURN *====================================================================== ENTRY YCLOCL !" CPU時間クリアー * TICK0 = ETIME( TARRAY ) TUSR0 = TARRAY( 1 ) * RETURN END *********************************************************************** SUBROUTINE MKFILN !" ファイル名 HCH を HREP に置き換え M ( HFILE , I HCH , HREP ) * * [MODIFY] CHARACTER HFILE *(*) * * [INPUT] CHARACTER HCH *1 CHARACTER HREP *(*) * * [INTERNAL WORK] INTEGER NFILN PARAMETER (NFILN=38) CHARACTER HFILX *(NFILN) INTEGER NFILE, NREP, I, II * * [EXTERNAL FUNC] INTEGER LENC * HFILX = HFILE HFILE = ' ' NREP = LENC( HREP ) NFILE = LEN ( HFILE ) II = 1 * DO 1100 I = 1, MIN( NFILE, NFILN ) IF ( II .GT. NFILE ) GOTO 1200 IF ( HFILX(I:I) .EQ. HCH ) THEN HFILE(II:II+NREP-1) = HREP(1:NREP) II = II + NREP ELSE HFILE(II:II) = HFILX(I:I) II = II + 1 ENDIF 1100 CONTINUE 1200 CONTINUE * RETURN END *********************************************************************** SUBROUTINE REWNML !" NAMELISTファイル, 入力巻き戻し O ( IFILE, JFILE ) * * [OUTPUT] INTEGER IFILE INTEGER JFILE * * [INTERNAL SAVE] INTEGER IFILEZ, JFILEZ DATA IFILEZ / 5 / DATA JFILEZ / 6 / SAVE * REWIND ( IFILEZ, ERR = 1999 ) IFILE = IFILEZ JFILE = JFILEZ RETURN * 1999 IF ( IFILEZ .EQ. 5 ) THEN CALL MSGDMP( 'W','REWNML','UNIT 5 MAY BE STANDARD INPUT' ) IFILE = IFILEZ JFILE = JFILEZ ELSE CALL MSGDMP( 'E','REWNML','ERROR IN REWINDING' ) * STOP ENDIF * RETURN *====================================================================== ENTRY SETNML !" NAMELIST入出力ファイルセット I ( IFILE, JFILE ) * IFILEZ = IFILE JFILEZ = JFILE * RETURN END *********************************************************************** SUBROUTINE YPREP !" システム前処理 * RETURN END *********************************************************************** SUBROUTINE YFINE !" システム後処理 * RETURN END *********************************************************************** INTEGER FUNCTION IOSLEV !" 入出力エラーレベル I ( IOS ) * * [INPUT] INTEGER IOS * IF ( IOS.EQ.0 ) THEN IOSLEV = 0 ELSE IOSLEV = 2 ENDIF * RETURN END *********************************************************************** SUBROUTINE YDATE !" 現在日付(yyyy mm dd)の取得 O ( HDATE ) * * [OUTPUT] CHARACTER HDATE *(*) !" 日付(yyyy/mm/dd) * * [INTERNAL WORK] INTEGER IDATE1 ( 3 ) !" 日付(yyyy, mm, dd) * CALL IDATE ( IDATE1 ) IF ( IDATE1(1) .LT. 100 ) IDATE1(1) = IDATE1(1) + 1900 HDATE = '****/0*/0*' WRITE ( HDATE(1:4) , '(I4)' ) IDATE1(1) WRITE ( HDATE(6:7) , '(I2.2)' ) IDATE1(2) WRITE ( HDATE(9:10), '(I2.2)' ) IDATE1(3) * RETURN END *********************************************************************** SUBROUTINE YTIME !" 現在時刻(hh mm ss)の取得 O ( HTIME ) * * [OUTPUT] CHARACTER HTIME *(*) !" 時刻(hh:mm:ss) * * [INTERNAL WORK] INTEGER ITIME1 ( 3 ) !" 時刻(hh, mm, ss) * CALL ITIME ( ITIME1 ) HTIME = '0*:0*:0*' WRITE ( HTIME(1:2), '(I2.2)' ) ITIME1(1) WRITE ( HTIME(4:5), '(I2.2)' ) ITIME1(2) WRITE ( HTIME(7:8), '(I2.2)' ) ITIME1(3) * RETURN END *********************************************************************** integer function common_handler !" デバッグ用関数 & (sig,code,sigcontext,addr) * integer sig,code,sigcontext(5) integer addr * write (0,10) loc(code), loc(addr) 10 format ("ieee exception ", z3, " occurred at address ", z8) end