C DEPMAC SOURCE PV 22/02/23 11:55:06 11291 C CET INTERESSANT SOUS-PROGRAMME S'EFFORCE DE CENTRALISER LES C FONCTIONS DEPENDANTES DU MATERIEL UTILISE C VOICI LA VERSION POUR LINUX,LINUX64,WIN32,WIN64 C SUBROUTINE DEPMAC implicit integer(i-n) external extint,long -INC PPARAM -INC CCOPTIO CHARACTER*8 USRNAM,cgibnam CHARACTER*(LOCHAI) cvarenv,chatest equivalence (cvarenv,ivarenv) logical ex,LOG1,LOG2,LOG3 DIMENSION EXTR(1),CBRACT(1),CARACT(1),ITTIME(4) character*(*) chacha REAL*8 XKT COMMON /CLGI/L6C CHARACTER*64 L6C SAVE KPREC DATA ICONT/1/ C C************************************************************************** C C INITIALISATION DU TIMER ITH=0 CALL TIMESPV(ITTIME,ITH) KPREC=(ITTIME(1)+ITTIME(2))/10 C graphiques X iogra=2 C lecture de fichier automatique iolec=3 C INITIALISATION NB DE ZERO CONSECUTIFS ( 48 POUR IBM RS/6000) IZROSF=48 C OUVERTURE DES FICHIERS ERREURS,NOTICE,PROCEDURE C GIBI.ERREUR en local INQUIRE(FILE='GIBI.ERREUR',EXIST=EX) if (ex) then cvarenv='GIBI.ERREUR' l=long(cvarenv) else cvarenv='CASTEM_ERREUR'//char(0) l=LOCHAI call ooozen(ivarenv,l) if (l.eq.0) then cvarenv='/u/castem/GIBI.ERREUR' l=long(cvarenv) endif endif OPEN (UNIT=35,FILE=CVARENV(1:L),STATUS='OLD',IOSTAT=IOSTAT, & FORM='FORMATTED') IF (IOSTAT.NE.0) THEN WRITE (6,FMT= & '('' ERREUR OUVERTURE DU FICHIER DE MESSAGES D''''ERREUR'')') UTIFI3(5)=-1 ELSE UTIFI3(5)=-1 ENDIF * y a t'il une langue dans l'environnement? cvarenv='CASTEM_LANGUE'//char(0) l=lochai call ooozen(ivarenv,l) if (l.ne.0) LANGUE=cvarenv(1:l) * La notice est maintenant faite dans infopn * La procedure est maintenant faite dans procpn C Recuperation de la variable d'environnement $CASTEM_PROJET cvarenv='CASTEM_PROJET'//char(0) l=LOCHAI call ooozen(ivarenv,l) LOG1 = .FALSE. LOG2 = .FALSE. IF (l .gt. 0) THEN C On teste avec le fichier exact donne dans $CASTEM_PROJET chatest=cvarenv(1:l) LL=l INQUIRE(FILE=chatest(1:LL), EXIST=LOG1, IOSTAT=IOSTAT,ERR=999) IF (LOG1) GOTO 101 C On teste avec .dgibi en plus a la fin chatest=cvarenv(1:l)//'.dgibi' LL=l+6 INQUIRE(FILE=chatest(1:LL), EXIST=LOG2, IOSTAT=IOSTAT,ERR=999) IF (LOG2) GOTO 101 C On teste avec .DGIBI en plus a la fin chatest=cvarenv(1:l)//'.DGIBI' LL=l+6 INQUIRE(FILE=chatest(1:LL), EXIST=LOG3, IOSTAT=IOSTAT,ERR=999) 101 CONTINUE IF (.NOT. LOG1 .AND. .NOT. LOG2 .AND. .NOT. LOG3) THEN C On n'a pas trouve le fichier demande chatest=cvarenv(1:l) LL=l open (unit=3 ,file='castem.null',iostat=iostat,ERR=999) ELSE open (unit=3 ,file=chatest(1:LL),iostat=iostat,ERR=999) ENDIF C On recherche la derniere extension IPLAC = INDEX(chatest(1:LL),'.',.TRUE.) IF(IPLAC .GT. 1 .AND. chatest(IPLAC:LL) .NE. '.trace' & .AND. chatest(IPLAC:LL) .NE. '.ps' ) THEN l=IPLAC-1 ENDIF cvarenv=chatest(1:l) C On ouvre les autres fichiers chatest=cvarenv(1:l)//'.trace' LL=l+6 open (unit=98,file=chatest(1:LL),iostat=iostat,ERR=999) chatest=cvarenv(1:l)//'.ps' LL=l+3 open (unit=24,file=chatest(1:LL),iostat=iostat,ERR=999) ELSE C $CASTEM_PROJET est vide open (unit=3 ,iostat=iostat,ERR=999) open (unit=98,iostat=iostat,ERR=999) open (unit=24,iostat=iostat,ERR=999) ENDIF C C INITIALISATION TABLES DE TRANSCODAGE POUR LE LGI L6C=':ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-*/()$= ,.' L6C(49:49)='#' L6C(50:50)=' ' L6C(51:51)='!' L6C(52:52)='%' L6C(53:53)='"' L6C(54:54)='_' L6C(55:55)='|' L6C(56:56)='&' L6C(57:57)='''' L6C(58:58)='?' L6C(59:59)='<' L6C(60:60)='>' L6C(61:61)='@' L6C(62:62)=CHAR(92) L6C(63:63)=CHAR(94) L6C(64:64)=CHAR(59) C initialisation du gestionnaire d'interruption (^C) call inthan RETURN 999 CONTINUE C Erreur d'ouverture de fichier INTERR(1)=1 LL=MAX(MIN(LL,40),1) MOTERR =' ' MOTERR(1:LL)=chatest(1:LL) CALL ERREUR(424) RETURN C C************************************************************************** C ENTRY GIBTEM(XKT) C TEMPS DEPUIS LE DERNIER APPEL EN CENTIEMES DE SECONDE ITH=0 CALL TIMESPV(ITTIME,ITH) KTOT=(ITTIME(1)+ITTIME(2))/10 KT=KTOT-KPREC XKT=KT KPREC=KTOT RETURN ENTRY GIBTRB C TRACE BACK RETURN C C************************************************************************** C ENTRY GIBDAT(JOUR,MOIS,IANNEE) C DATE (EN ENTIERS) CALL OOOZZ1(ITTIME) JOUR=ITTIME(1) MOIS=ITTIME(2) IANNEE=ITTIME(3) RETURN ENTRY GIBECO(IECO) C TEST ENVIRONNEMENT (BATCH OU INTERACTIF) IECO=1 RETURN C C************************************************************************** C C recuperer le nom utilisateur ENTRY GIBNAM(USRNAM) usrnam=cgibnam(usrnam) return C C************************************************************************** C entry prompt c prompt (si on peut le faire) write (ioimp,fmt='('' $ '',$)') return C C************************************************************************** C entry xread(chacha,lon) c pour windows lecture instruction read (ioter,fmt='(A72)') chacha lon=long(chacha) return C C************************************************************************** C C TRAITEMENT D'ERREUR IBM C ON MET SUR TOUTE ERREUR D'EXECUTION IERR A 1 C ET ON POURSUIT L'EXECUTION C ON LAISSE UN MESSAGE D'ERREUR S'IMPRIMER entry errcor C points d'entree a supprimer sur RS/6000 entry cp(chacha) entry cms(chacha) entry elpdyn entry elpsta C GDDM entry asdfld entry asfcol entry asftrn entry asftra entry asqmax entry fsrnit entry ascput entry asread entry asqcur entry ascget entry fsinit entry fsinn entry dsopen entry dsuse entry fsqury entry gslss entry fspcrt entry gsfld entry gsqps entry gswin entry gssati entry gsseg entry gstag entry gscm entry gscol entry gschar entry gsqcb entry gscb entry gsscls entry gsview entry gsclp entry gsuwin entry gsmix entry gsmove entry gsplne entry gsenab entry gsiloc entry gsread entry gsqcho entry gsqloc entry gspat entry gsarea entry gsenda entry gsqwin entry gsqlid entry gsidvf entry gsstfm entry gssdel entry gsqaga entry gssats entry gssave entry gscopy entry fscopy entry fscls entry gsclr entry fsfrce entry asfcur CPHIGS entry pads entry parst entry patr entry pcelst entry pclst entry pdst entry pemst entry pevmm entry pexst entry pfa entry poparf entry popph entry popst entry popwk entry ppl entry ppost entry pqdsp entry pqopst entry pqopwk entry prqlc entry prqpk entry prqst entry psans entry psatch entry pschsp entry pscr entry psdus entry psici entry psis entry psivft entry pslcm entry pspkft entry pspkid entry pspkm entry psplci entry pspmci entry psstm entry pstxci entry pstxfn entry pstxpr C entry psvis entry psvtip entry psvwi entry psvwr entry pswkv entry pswkw entry pupast entry puwk C GKS entry gacwk entry gasgwk entry gclsg entry gclwk entry gcrsg entry gdawk entry gdsg entry gfa entry ginlc entry ginsg entry gmsg entry gopks entry gopwk entry gpl entry gqchh entry gqchxp entry gqdsp entry gqops entry gqopsg entry gqopwk entry gqsga entry gqsgus entry gqwks entry grensg entry grqlc entry grqpk entry grqst entry gsasf entry gschh entry gschsp entry gschxp entry gscr entry gsds entry gsdtec entry gselnt entry gsfaci entry gsfais entry gslcm entry gspkm entry gsplci entry gspmci entry gssgt entry gsstm entry gstxci entry gstxfp entry gsvis entry gsvp entry gswkvp entry gswkwn entry gswn entry gtx entry guwk END C C************************************************************************** C C gestionnaire d'interruption (^C) subroutine extint implicit integer(i-n) -INC PPARAM -INC CCOPTIO C regenerer le signal puis positionner une erreur call inthan ierr =623 IERGLB=623 end C C C************************************************************************** C C mise en place gestionnaire d'interruption (^C) subroutine inthan implicit integer(i-n) external extint call signal(2,extint) end C C************************************************************************** C C reouverture du terminal apres une interruption clavier (si necessaire) subroutine opterm(iun) implicit integer(i-n) close (unit=iun) *** PRINT*,'DEPMAC - opterm',iun %IF WIN32,WIN64 open (unit=iun,file='con:') %ELSE open (unit=iun,file='/dev/tty') %ENDIF end