Télécharger la plaquette Cast3M


fr en

Télécharger depmac.eso

Retour à la liste

Numérotation des lignes : 

depmac

  1. C DEPMAC    SOURCE    PV        22/02/23    11:55:06     11291          
  2. C  CET INTERESSANT SOUS-PROGRAMME S'EFFORCE DE CENTRALISER LES
  3. C  FONCTIONS DEPENDANTES DU MATERIEL UTILISE
  4. C  VOICI LA VERSION POUR LINUX,LINUX64,WIN32,WIN64
  5. C
  6.       SUBROUTINE DEPMAC
  7.  
  8.       implicit integer(i-n)
  9.       external extint,long
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13.  
  14.       CHARACTER*8 USRNAM,cgibnam
  15.       CHARACTER*(LOCHAI) cvarenv,chatest
  16.       equivalence (cvarenv,ivarenv)
  17.       logical ex,LOG1,LOG2,LOG3
  18.       DIMENSION EXTR(1),CBRACT(1),CARACT(1),ITTIME(4)
  19.       character*(*) chacha
  20.       REAL*8 XKT
  21.       COMMON /CLGI/L6C
  22.       CHARACTER*64 L6C
  23.       SAVE KPREC
  24.       DATA ICONT/1/
  25. C
  26. C**************************************************************************
  27. C
  28. C  INITIALISATION DU TIMER
  29.       ITH=0
  30.       CALL TIMESPV(ITTIME,ITH)
  31.       KPREC=(ITTIME(1)+ITTIME(2))/10
  32. C  graphiques X
  33.       iogra=2
  34. C  lecture de fichier automatique
  35.       iolec=3
  36. C  INITIALISATION NB DE ZERO CONSECUTIFS ( 48 POUR IBM RS/6000)
  37.       IZROSF=48
  38.  
  39. C OUVERTURE DES FICHIERS ERREURS,NOTICE,PROCEDURE
  40. C     GIBI.ERREUR en local
  41.       INQUIRE(FILE='GIBI.ERREUR',EXIST=EX)
  42.       if (ex) then
  43.         cvarenv='GIBI.ERREUR'
  44.         l=long(cvarenv)
  45.       else
  46.         cvarenv='CASTEM_ERREUR'//char(0)
  47.         l=LOCHAI
  48.         call ooozen(ivarenv,l)
  49.         if (l.eq.0) then
  50.           cvarenv='/u/castem/GIBI.ERREUR'
  51.           l=long(cvarenv)
  52.         endif
  53.       endif
  54.       OPEN (UNIT=35,FILE=CVARENV(1:L),STATUS='OLD',IOSTAT=IOSTAT,
  55.      &      FORM='FORMATTED')
  56.       IF (IOSTAT.NE.0)  THEN
  57.         WRITE (6,FMT=
  58.      &    '('' ERREUR OUVERTURE DU FICHIER DE MESSAGES D''''ERREUR'')')
  59.         UTIFI3(5)=-1
  60.       ELSE
  61.         UTIFI3(5)=-1
  62.       ENDIF
  63. * y a t'il une langue dans l'environnement?
  64.       cvarenv='CASTEM_LANGUE'//char(0)
  65.       l=lochai
  66.       call ooozen(ivarenv,l)
  67.       if (l.ne.0) LANGUE=cvarenv(1:l)
  68. *  La notice est maintenant faite dans infopn
  69. *  La procedure est maintenant faite dans procpn
  70.  
  71. C     Recuperation de la variable d'environnement $CASTEM_PROJET
  72.       cvarenv='CASTEM_PROJET'//char(0)
  73.       l=LOCHAI
  74.       call ooozen(ivarenv,l)      
  75.  
  76.       LOG1 = .FALSE.
  77.       LOG2 = .FALSE.
  78.       IF (l .gt. 0) THEN
  79. C       On teste avec le fichier exact donne dans $CASTEM_PROJET
  80.         chatest=cvarenv(1:l)
  81.         LL=l
  82.  
  83.         INQUIRE(FILE=chatest(1:LL), EXIST=LOG1, IOSTAT=IOSTAT,ERR=999)
  84.         IF (LOG1) GOTO 101
  85.  
  86. C       On teste avec .dgibi en plus a la fin
  87.         chatest=cvarenv(1:l)//'.dgibi'
  88.         LL=l+6
  89.         INQUIRE(FILE=chatest(1:LL), EXIST=LOG2, IOSTAT=IOSTAT,ERR=999)
  90.         IF (LOG2) GOTO 101
  91.  
  92. C       On teste avec .DGIBI en plus a la fin
  93.         chatest=cvarenv(1:l)//'.DGIBI'
  94.         LL=l+6
  95.         INQUIRE(FILE=chatest(1:LL), EXIST=LOG3, IOSTAT=IOSTAT,ERR=999)
  96.  
  97.  101    CONTINUE
  98.         IF (.NOT. LOG1 .AND. .NOT. LOG2 .AND. .NOT. LOG3) THEN
  99. C         On n'a pas trouve le fichier demande
  100.           chatest=cvarenv(1:l)
  101.           LL=l
  102.           open (unit=3 ,file='castem.null',iostat=iostat,ERR=999)
  103.         ELSE 
  104.           open (unit=3 ,file=chatest(1:LL),iostat=iostat,ERR=999)
  105.         ENDIF
  106.  
  107. C       On recherche la derniere extension
  108.         IPLAC = INDEX(chatest(1:LL),'.',.TRUE.)
  109.         IF(IPLAC .GT. 1 .AND. chatest(IPLAC:LL) .NE. '.trace'
  110.      &                  .AND. chatest(IPLAC:LL) .NE. '.ps'   ) THEN
  111.           l=IPLAC-1
  112.         ENDIF
  113.         cvarenv=chatest(1:l)
  114.  
  115. C       On ouvre les autres fichiers
  116.         chatest=cvarenv(1:l)//'.trace'
  117.         LL=l+6
  118.         open (unit=98,file=chatest(1:LL),iostat=iostat,ERR=999)
  119.  
  120.         chatest=cvarenv(1:l)//'.ps'
  121.         LL=l+3
  122.         open (unit=24,file=chatest(1:LL),iostat=iostat,ERR=999)
  123.  
  124.       ELSE
  125. C       $CASTEM_PROJET est vide
  126.         open (unit=3 ,iostat=iostat,ERR=999)
  127.         open (unit=98,iostat=iostat,ERR=999)
  128.         open (unit=24,iostat=iostat,ERR=999)
  129.       ENDIF
  130.  
  131. C
  132. C  INITIALISATION TABLES DE TRANSCODAGE POUR LE LGI
  133.       L6C=':ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-*/()$= ,.'
  134.       L6C(49:49)='#'
  135.       L6C(50:50)=' '
  136.       L6C(51:51)='!'
  137.       L6C(52:52)='%'
  138.       L6C(53:53)='"'
  139.       L6C(54:54)='_'
  140.       L6C(55:55)='|'
  141.       L6C(56:56)='&'
  142.       L6C(57:57)=''''
  143.       L6C(58:58)='?'
  144.       L6C(59:59)='<'
  145.       L6C(60:60)='>'
  146.       L6C(61:61)='@'
  147.       L6C(62:62)=CHAR(92)
  148.       L6C(63:63)=CHAR(94)
  149.       L6C(64:64)=CHAR(59)
  150. C initialisation du gestionnaire d'interruption (^C)
  151.        call inthan
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.       RETURN
  170.  999  CONTINUE
  171. C     Erreur d'ouverture de fichier
  172.       INTERR(1)=1
  173.       LL=MAX(MIN(LL,40),1)
  174.       MOTERR      =' '
  175.       MOTERR(1:LL)=chatest(1:LL)
  176.       CALL ERREUR(424)
  177.       RETURN
  178. C
  179. C**************************************************************************
  180. C
  181.       ENTRY GIBTEM(XKT)
  182. C  TEMPS DEPUIS LE DERNIER APPEL EN CENTIEMES DE SECONDE
  183.       ITH=0
  184.       CALL TIMESPV(ITTIME,ITH)
  185.       KTOT=(ITTIME(1)+ITTIME(2))/10
  186.       KT=KTOT-KPREC
  187.       XKT=KT
  188.       KPREC=KTOT
  189.       RETURN
  190.       ENTRY GIBTRB
  191. C  TRACE BACK
  192.       RETURN
  193. C
  194. C**************************************************************************
  195. C
  196.       ENTRY GIBDAT(JOUR,MOIS,IANNEE)
  197. C  DATE (EN ENTIERS)
  198.       CALL OOOZZ1(ITTIME)
  199.       JOUR=ITTIME(1)
  200.       MOIS=ITTIME(2)
  201.       IANNEE=ITTIME(3)
  202.       RETURN
  203.       ENTRY GIBECO(IECO)
  204. C  TEST ENVIRONNEMENT (BATCH OU INTERACTIF)
  205.       IECO=1
  206.       RETURN
  207. C
  208. C**************************************************************************
  209. C
  210. C   recuperer le nom utilisateur
  211.       ENTRY GIBNAM(USRNAM)
  212.       usrnam=cgibnam(usrnam)
  213.       return
  214. C
  215. C**************************************************************************
  216. C
  217.       entry prompt
  218. c  prompt (si on peut le faire)
  219.       write (ioimp,fmt='('' $ '',$)')
  220.       return
  221. C
  222. C**************************************************************************
  223. C
  224.       entry xread(chacha,lon)
  225. c  pour windows lecture instruction
  226.       read (ioter,fmt='(A72)') chacha
  227.       lon=long(chacha)
  228.       return
  229. C
  230. C**************************************************************************
  231. C
  232. C  TRAITEMENT D'ERREUR IBM
  233. C  ON MET SUR TOUTE ERREUR D'EXECUTION IERR A 1
  234. C  ET ON POURSUIT L'EXECUTION
  235. C  ON LAISSE UN MESSAGE D'ERREUR S'IMPRIMER
  236.       entry errcor
  237. C points d'entree a supprimer sur RS/6000
  238.       entry cp(chacha)
  239.       entry cms(chacha)
  240.       entry elpdyn
  241.       entry elpsta
  242. C  GDDM
  243.       entry asdfld
  244.       entry asfcol
  245.       entry asftrn
  246.       entry asftra
  247.       entry asqmax
  248.       entry fsrnit
  249.       entry ascput
  250.       entry asread
  251.       entry asqcur
  252.       entry ascget
  253.       entry fsinit
  254.       entry fsinn
  255.       entry dsopen
  256.       entry dsuse
  257.       entry fsqury
  258.       entry gslss
  259.       entry fspcrt
  260.       entry gsfld
  261.       entry gsqps
  262.       entry gswin
  263.       entry gssati
  264.       entry gsseg
  265.       entry gstag
  266.       entry gscm
  267.       entry gscol
  268.       entry gschar
  269.       entry gsqcb
  270.       entry gscb
  271.       entry gsscls
  272.       entry gsview
  273.       entry gsclp
  274.       entry gsuwin
  275.       entry gsmix
  276.       entry gsmove
  277.       entry gsplne
  278.       entry gsenab
  279.       entry gsiloc
  280.       entry gsread
  281.       entry gsqcho
  282.       entry gsqloc
  283.       entry gspat
  284.       entry gsarea
  285.       entry gsenda
  286.       entry gsqwin
  287.       entry gsqlid
  288.       entry gsidvf
  289.       entry gsstfm
  290.       entry gssdel
  291.       entry gsqaga
  292.       entry gssats
  293.       entry gssave
  294.       entry gscopy
  295.       entry fscopy
  296.       entry fscls
  297.       entry gsclr
  298.       entry fsfrce
  299.       entry asfcur
  300. CPHIGS
  301.        entry pads
  302.        entry parst
  303.        entry patr
  304.        entry pcelst
  305.        entry pclst
  306.        entry pdst
  307.        entry pemst
  308.        entry pevmm
  309.        entry pexst
  310.        entry pfa
  311.        entry poparf
  312.        entry popph
  313.        entry popst
  314.        entry popwk
  315.        entry ppl
  316.        entry ppost
  317.        entry pqdsp
  318.        entry pqopst
  319.        entry pqopwk
  320.        entry prqlc
  321.        entry prqpk
  322.        entry prqst
  323.        entry psans
  324.        entry psatch
  325.        entry pschsp
  326.        entry pscr
  327.        entry psdus
  328.        entry psici
  329.        entry psis
  330.        entry psivft
  331.        entry pslcm
  332.        entry pspkft
  333.        entry pspkid
  334.        entry pspkm
  335.        entry psplci
  336.        entry pspmci
  337.        entry psstm
  338.        entry pstxci
  339.        entry pstxfn
  340.        entry pstxpr
  341. C      entry psvis
  342.        entry psvtip
  343.        entry psvwi
  344.        entry psvwr
  345.        entry pswkv
  346.        entry pswkw
  347.        entry pupast
  348.        entry puwk
  349. C  GKS
  350.  
  351.        entry gacwk
  352.        entry gasgwk
  353.        entry gclsg
  354.        entry gclwk
  355.        entry gcrsg
  356.        entry gdawk
  357.        entry gdsg
  358.        entry gfa
  359.        entry ginlc
  360.        entry ginsg
  361.        entry gmsg
  362.        entry gopks
  363.        entry gopwk
  364.        entry gpl
  365.        entry gqchh
  366.        entry gqchxp
  367.        entry gqdsp
  368.        entry gqops
  369.        entry gqopsg
  370.        entry gqopwk
  371.        entry gqsga
  372.        entry gqsgus
  373.        entry gqwks
  374.        entry grensg
  375.        entry grqlc
  376.        entry grqpk
  377.        entry grqst
  378.        entry gsasf
  379.        entry gschh
  380.        entry gschsp
  381.        entry gschxp
  382.        entry gscr
  383.        entry gsds
  384.        entry gsdtec
  385.        entry gselnt
  386.        entry gsfaci
  387.        entry gsfais
  388.        entry gslcm
  389.        entry gspkm
  390.        entry gsplci
  391.        entry gspmci
  392.        entry gssgt
  393.        entry gsstm
  394.        entry gstxci
  395.        entry gstxfp
  396.        entry gsvis
  397.        entry gsvp
  398.        entry gswkvp
  399.        entry gswkwn
  400.        entry gswn
  401.        entry gtx
  402.        entry guwk
  403.       END
  404. C
  405. C**************************************************************************
  406. C
  407. C  gestionnaire d'interruption (^C)
  408.       subroutine extint
  409.       implicit integer(i-n)
  410. -INC PPARAM
  411. -INC CCOPTIO
  412. C  regenerer le signal puis positionner une erreur
  413.       call inthan
  414.       ierr  =623
  415.       IERGLB=623
  416.       end
  417. C
  418. C
  419. C**************************************************************************
  420. C
  421. C  mise en place gestionnaire d'interruption (^C)
  422.       subroutine inthan
  423.       implicit integer(i-n)
  424.       external extint
  425.       call signal(2,extint)
  426.       end
  427. C
  428. C**************************************************************************
  429. C
  430. C  reouverture du terminal apres une interruption clavier (si necessaire)
  431.       subroutine opterm(iun)
  432.       implicit integer(i-n)
  433.       close (unit=iun)
  434. ***     PRINT*,'DEPMAC - opterm',iun
  435. %IF WIN32,WIN64
  436.       open  (unit=iun,file='con:')
  437. %ELSE
  438.       open  (unit=iun,file='/dev/tty')
  439. %ENDIF
  440.       end
  441.  
  442.  
  443.  
  444.  
  445.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales