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
  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.  
  124. 101 CONTINUE
  125. IF (LOG1 .OR. LOG2) THEN
  126. C On a trouve le fichier demande
  127. open (unit=3 ,file=chatest(1:LL),iostat=iostat,ERR=999)
  128.  
  129. ELSE
  130. C On n'a pas trouve le fichier demande
  131. open (unit=3 ,iostat=iostat,ERR=999)
  132. chatest=cvarenv(1:l)
  133. LL=l
  134. ENDIF
  135.  
  136. C On recherche la derniere extension
  137. IPLAC = INDEX(chatest(1:LL),'.',.TRUE.)
  138. IF(IPLAC .GT. 1 .AND. chatest(IPLAC:LL) .NE. '.trace'
  139. & .AND. chatest(IPLAC:LL) .NE. '.ps' ) THEN
  140. l=IPLAC-1
  141. ENDIF
  142. cvarenv=chatest(1:l)
  143.  
  144. C On ouvre les autres fichiers
  145. chatest=cvarenv(1:l)//'.trace'
  146. LL=l+6
  147. open (unit=98,file=chatest(1:LL),iostat=iostat,ERR=999)
  148.  
  149. chatest=cvarenv(1:l)//'.ps'
  150. LL=l+3
  151. open (unit=24,file=chatest(1:LL),iostat=iostat,ERR=999)
  152.  
  153. ELSE
  154. C $CASTEM_PROJET est vide
  155. open (unit=3 ,iostat=iostat,ERR=999)
  156. open (unit=98,iostat=iostat,ERR=999)
  157. open (unit=24,iostat=iostat,ERR=999)
  158. ENDIF
  159.  
  160. C
  161. C INITIALISATION TABLES DE TRANSCODAGE POUR LE LGI
  162. L6C=':ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-*/()$= ,.'
  163. L6C(49:49)='#'
  164. L6C(50:50)=''
  165. L6C(51:51)='!'
  166. L6C(52:52)='%'
  167. L6C(53:53)='"'
  168. L6C(54:54)='_'
  169. L6C(55:55)='|'
  170. L6C(56:56)='&'
  171. L6C(57:57)=''''
  172. L6C(58:58)='?'
  173. L6C(59:59)='<'
  174. L6C(60:60)='>'
  175. L6C(61:61)='@'
  176. L6C(62:62)=CHAR(92)
  177. L6C(63:63)=CHAR(94)
  178. L6C(64:64)=CHAR(59)
  179. C initialisation du gestionnaire d'interruption (^C)
  180. call inthan
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198. RETURN
  199. 999 CONTINUE
  200. C Erreur d'ouverture de fichier
  201. INTERR(1)=1
  202. LL=MAX(MIN(LL,40),1)
  203. MOTERR =' '
  204. MOTERR(1:LL)=chatest(1:LL)
  205. CALL ERREUR(424)
  206. RETURN
  207. C
  208. C**************************************************************************
  209. C
  210. ENTRY GIBTEM(XKT)
  211. C TEMPS DEPUIS LE DERNIER APPEL EN CENTIEMES DE SECONDE
  212. CALL TIMESPV(ITTIME)
  213. KTOT=(ITTIME(1)+ITTIME(2))/10
  214. KT=KTOT-KPREC
  215. XKT=KT
  216. KPREC=KTOT
  217. RETURN
  218. ENTRY GIBTRB
  219. C TRACE BACK
  220. RETURN
  221. C
  222. C**************************************************************************
  223. C
  224. ENTRY GIBDAT(JOUR,MOIS,IANNEE)
  225. C DATE (EN ENTIERS)
  226. CALL OOOZZ1(ITTIME)
  227. JOUR=ITTIME(1)
  228. MOIS=ITTIME(2)
  229. IANNEE=ITTIME(3)
  230. RETURN
  231. ENTRY GIBECO(IECO)
  232. C TEST ENVIRONNEMENT (BATCH OU INTERACTIF)
  233. IECO=1
  234. RETURN
  235. C
  236. C**************************************************************************
  237. C
  238. C recuperer le nom utilisateur
  239. ENTRY GIBNAM(USRNAM)
  240. usrnam=cgibnam(usrnam)
  241. return
  242. C
  243. C**************************************************************************
  244. C
  245. entry prompt
  246. c prompt (si on peut le faire)
  247. write (ioimp,fmt='('' $ '',$)')
  248. return
  249. C
  250. C**************************************************************************
  251. C
  252. entry xread(chacha,lon)
  253. c pour windows lecture instruction
  254. read (ioter,fmt='(A72)') chacha
  255. lon=long(chacha)
  256. return
  257. C
  258. C**************************************************************************
  259. C
  260. C TRAITEMENT D'ERREUR IBM
  261. C ON MET SUR TOUTE ERREUR D'EXECUTION IERR A 1
  262. C ET ON POURSUIT L'EXECUTION
  263. C ON LAISSE UN MESSAGE D'ERREUR S'IMPRIMER
  264. entry errcor
  265. C points d'entree a supprimer sur RS/6000
  266. entry cp(chacha)
  267. entry cms(chacha)
  268. entry elpdyn
  269. entry elpsta
  270. C GDDM
  271. entry asdfld
  272. entry asfcol
  273. entry asftrn
  274. entry asftra
  275. entry asqmax
  276. entry fsrnit
  277. entry ascput
  278. entry asread
  279. entry asqcur
  280. entry ascget
  281. entry fsinit
  282. entry fsinn
  283. entry dsopen
  284. entry dsuse
  285. entry fsqury
  286. entry gslss
  287. entry fspcrt
  288. entry gsfld
  289. entry gsqps
  290. entry gswin
  291. entry gssati
  292. entry gsseg
  293. entry gstag
  294. entry gscm
  295. entry gscol
  296. entry gschar
  297. entry gsqcb
  298. entry gscb
  299. entry gsscls
  300. entry gsview
  301. entry gsclp
  302. entry gsuwin
  303. entry gsmix
  304. entry gsmove
  305. entry gsplne
  306. entry gsenab
  307. entry gsiloc
  308. entry gsread
  309. entry gsqcho
  310. entry gsqloc
  311. entry gspat
  312. entry gsarea
  313. entry gsenda
  314. entry gsqwin
  315. entry gsqlid
  316. entry gsidvf
  317. entry gsstfm
  318. entry gssdel
  319. entry gsqaga
  320. entry gssats
  321. entry gssave
  322. entry gscopy
  323. entry fscopy
  324. entry fscls
  325. entry gsclr
  326. entry fsfrce
  327. entry asfcur
  328. CPHIGS
  329. entry pads
  330. entry parst
  331. entry patr
  332. entry pcelst
  333. entry pclst
  334. entry pdst
  335. entry pemst
  336. entry pevmm
  337. entry pexst
  338. entry pfa
  339. entry poparf
  340. entry popph
  341. entry popst
  342. entry popwk
  343. entry ppl
  344. entry ppost
  345. entry pqdsp
  346. entry pqopst
  347. entry pqopwk
  348. entry prqlc
  349. entry prqpk
  350. entry prqst
  351. entry psans
  352. entry psatch
  353. entry pschsp
  354. entry pscr
  355. entry psdus
  356. entry psici
  357. entry psis
  358. entry psivft
  359. entry pslcm
  360. entry pspkft
  361. entry pspkid
  362. entry pspkm
  363. entry psplci
  364. entry pspmci
  365. entry psstm
  366. entry pstxci
  367. entry pstxfn
  368. entry pstxpr
  369. C entry psvis
  370. entry psvtip
  371. entry psvwi
  372. entry psvwr
  373. entry pswkv
  374. entry pswkw
  375. entry pupast
  376. entry puwk
  377. C GKS
  378.  
  379. entry gacwk
  380. entry gasgwk
  381. entry gclsg
  382. entry gclwk
  383. entry gcrsg
  384. entry gdawk
  385. entry gdsg
  386. entry gfa
  387. entry ginlc
  388. entry ginsg
  389. entry gmsg
  390. entry gopks
  391. entry gopwk
  392. entry gpl
  393. entry gqchh
  394. entry gqchxp
  395. entry gqdsp
  396. entry gqops
  397. entry gqopsg
  398. entry gqopwk
  399. entry gqsga
  400. entry gqsgus
  401. entry gqwks
  402. entry grensg
  403. entry grqlc
  404. entry grqpk
  405. entry grqst
  406. entry gsasf
  407. entry gschh
  408. entry gschsp
  409. entry gschxp
  410. entry gscr
  411. entry gsds
  412. entry gsdtec
  413. entry gselnt
  414. entry gsfaci
  415. entry gsfais
  416. entry gslcm
  417. entry gspkm
  418. entry gsplci
  419. entry gspmci
  420. entry gssgt
  421. entry gsstm
  422. entry gstxci
  423. entry gstxfp
  424. entry gsvis
  425. entry gsvp
  426. entry gswkvp
  427. entry gswkwn
  428. entry gswn
  429. entry gtx
  430. entry guwk
  431.  
  432.  
  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. END
  463. C
  464. C**************************************************************************
  465. C
  466. C gestionnaire d'interruption (^C)
  467. subroutine extint
  468. implicit integer(i-n)
  469. -INC CCOPTIO
  470. C regenerer le signal puis positionner une erreur
  471. call inthan
  472. ierr=623
  473. end
  474. C
  475. C
  476. C**************************************************************************
  477. C
  478. C mise en place gestionnaire d'interruption (^C)
  479. subroutine inthan
  480. implicit integer(i-n)
  481. external extint
  482. call signal(2,extint)
  483. end
  484. C
  485. C**************************************************************************
  486. C
  487. C reouverture du terminal apres une interruption clavier (si necessaire)
  488. subroutine opterm(iun)
  489. implicit integer(i-n)
  490. close (unit=iun)
  491. open (unit=iun,file='/dev/tty')
  492. end
  493.  
  494.  

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