Télécharger depmac.eso

Retour à la liste

Numérotation des lignes :

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

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