Télécharger depmac.eso

Retour à la liste

Numérotation des lignes :

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

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