Télécharger depmac.eso

Retour à la liste

Numérotation des lignes :

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

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