Télécharger eqpr.eso

Retour à la liste

Numérotation des lignes :

  1. C EQPR SOURCE JC220346 18/12/04 21:15:22 9991
  2. SUBROUTINE EQPR
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC CCNOYAU
  9. -INC SMLENTI
  10. -INC SMLREEL
  11. -INC SMLMOTS
  12. POINTEUR MINCO.MLMOTS
  13. -INC SMTABLE
  14. POINTEUR MTABX.MTABLE,KIZL.MTABLE,KIZS.MTABLE,KIZC.MTABLE
  15. -INC SMELEME
  16. PARAMETER (NBM=5)
  17. CHARACTER*8 LMOTS(NBM),NOM,MEQUA,NOMO,MTYP,MOQ(2)
  18. CHARACTER*(LONOM) NOMZ
  19. CHARACTER*8 TYPE,TYP2,TYPS,TYPC
  20.  
  21. PARAMETER (NTB=2)
  22. CHARACTER*8 LTAB(NTB)
  23. DIMENSION KTAB(NTB)
  24. DATA LMOTS /'ZONE ','OPER ','KTYPI ','BETA ',
  25. & 'PIMP '/
  26. DATA LTAB/'DOMAINE ','EQPR '/
  27. C***
  28.  
  29. CALL QUETYP(TYPE,0,IRET)
  30.  
  31. MMODEL=0
  32. IF(TYPE.EQ.'MMODEL')THEN
  33. CALL LIROBJ('MMODEL',MMODEL,0,IRET)
  34. CALL LEKMOD(MMODEL,MTBLE,INEFMD)
  35. IF(MTBLE.EQ.0)RETURN
  36. KTAB(1)=MTBLE
  37. KTAB(2)=0
  38.  
  39. ELSEIF(TYPE.EQ.'TABLE')THEN
  40. CALL LIROBJ(TYPE,MTBLE,0,IRET)
  41. TYPC=' '
  42. CALL ACMO(MTBLE,'SOUSTYPE',TYPC,IRET)
  43. IF(TYPC.EQ.'MOT ')THEN
  44. CALL ACMM(MTBLE,'SOUSTYPE',TYPS)
  45. IF(TYPS.EQ.'DOMAINE')THEN
  46. KTAB(1)=MTBLE
  47. KTAB(2)=0
  48. ELSEIF(TYPS.EQ.'EQPR')THEN
  49. KTAB(1)=0
  50. KTAB(2)=MTBLE
  51. ELSE
  52. WRITE(IOIMP,*)' On attend une table soustype DOMAINE ou EQEX'
  53. RETURN
  54. ENDIF
  55. ENDIF
  56. ENDIF
  57.  
  58. C???
  59. C??? NTO=0
  60. C??? CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  61. C??? IF(IRET.EQ.0)THEN
  62. C??? WRITE(6,*)' On attend une table soustype DOMAINE ou EQPR'
  63. C??? RETURN
  64. C??? ENDIF
  65. IF(KTAB(1).NE.0.AND.KTAB(2).NE.0)THEN
  66. WRITE(6,*)' On ne peut donner simultanement les deux tables'
  67. RETURN
  68. ENDIF
  69.  
  70. IF(KTAB(2).NE.0)THEN
  71. MTABLE=KTAB(2)
  72. SEGACT MTABLE
  73. MTYP='LISTMOTS'
  74. CALL ACMO(MTABLE,'LISTOPER',MTYP,MLMOT1)
  75. SEGACT MLMOT1
  76. NEQUA=MLMOT1.MOTS(/2)
  77. ELSEIF(KTAB(1).NE.0)THEN
  78. MTABD=KTAB(1)
  79. CALL CRTABL(MTABLE)
  80. NEQUA=0
  81. CALL ECMM(MTABLE,'SOUSTYPE','EQPR')
  82. CALL ECMO(MTABLE,'DOMAINE','TABLE ',MTABD)
  83.  
  84. TYPE=' '
  85. CALL ACMO(MTABD,'MACRO',TYPE,IMAC)
  86. IF(TYPE.NE.'MAILLAGE')THEN
  87. CALL ECME(MTABLE,'KBETA',0)
  88. CALL ECMF(MTABLE,'BETA',0.D0)
  89. ELSE
  90. CALL ECME(MTABLE,'KBETA',1)
  91. CALL ECMF(MTABLE,'BETA',1.D0)
  92. ENDIF
  93.  
  94. CALL ECME(MTABLE,'KTYPI',1)
  95.  
  96. CALL ECME(MTABLE,'KPIMP',0)
  97. CALL ECMF(MTABLE,'PIMP',0.D0)
  98. JGN=8
  99. JGM=0
  100. SEGINI MLMOT1
  101. CALL ECMO(MTABLE,'LISTOPER','LISTMOTS',MLMOT1)
  102. ELSE
  103. WRITE(6,*)' On attend une table ou un objet maillage'
  104. RETURN
  105. ENDIF
  106.  
  107. 1 CONTINUE
  108. CALL LIRCHA(NOM,0,IRET)
  109. IF(IRET.EQ.0)GO TO 90
  110. 2 CONTINUE
  111. C write(6,*)' EQPR : nom=',nom
  112. CALL OPTLI(IP,LMOTS,NOM,NBM)
  113. IF(IP.EQ.0)THEN
  114. WRITE(6,*)'OPTION NON TROUVE DANS LA LISTE ->',LMOTS
  115. RETURN
  116. ENDIF
  117.  
  118. GO TO (10,11,12,14,15),IP
  119.  
  120. 10 CONTINUE
  121. C ON LIT LA ZONE
  122.  
  123. CALL LITABS(LTAB,KTAB,1,0,IRET)
  124.  
  125. MMODEL=0
  126. IF(KTAB(1).EQ.0)THEN
  127. CALL LIROBJ('MMODEL',MMODEL,0,IRET2)
  128. IF(IRET2.EQ.0)THEN
  129. WRITE(IOIMP,*)' On attend un objet TABLE DOMAINE ou MODELE'
  130. RETURN
  131. ENDIF
  132. CALL LEKMOD(MMODEL,MTBLE,INEFMD)
  133. IF(MTBLE.EQ.0)RETURN
  134. KTAB(1)=MTBLE
  135. ENDIF
  136.  
  137. C??? IF(IRET.EQ.0)THEN
  138. C??? WRITE(6,*)' On attend un objet TABLE DOMAINE'
  139. C??? RETURN
  140. C??? ENDIF
  141.  
  142. CALL QUENOM(NOMZ)
  143. C write(6,*)' NOM de la zone ',NOMZ
  144. GO TO 1
  145.  
  146. 11 CONTINUE
  147. CALL LIRCHA(NOM,1,IRET)
  148. IF(IRET.EQ.0)THEN
  149. WRITE(6,*)' ON ATTEND LE NOM DE L OPERATEUR'
  150. RETURN
  151. C write(6,*)' NOM de l opérateur ',NOM
  152. ENDIF
  153.  
  154. * ECRITURE DU NOM DE L'OPERATEUR
  155. NOMO=NOM
  156.  
  157. NEQUA=NEQUA+1
  158. IF(NEQUA.LT.10)THEN
  159. WRITE(MEQUA,FMT='(I1,A7)')NEQUA,NOMO(1:7)
  160. ELSEIF(NEQUA.LT.100.AND.NEQUA.GE.10)THEN
  161. WRITE(MEQUA,FMT='(I2,A6)')NEQUA,NOMO(1:6)
  162. ELSE
  163. WRITE(6,*)'PLUS DE 99 OPERATEURS : CAS NON PREVU'
  164. RETURN
  165. ENDIF
  166. JGN=8
  167. JGM=MLMOT1.MOTS(/2)+1
  168. SEGADJ MLMOT1
  169. MLMOT1.MOTS(JGM)=MEQUA
  170. CALL LENCHA(MEQUA,LC1)
  171. CALL CRTABL(MTABX)
  172. CALL ECMM(MTABX,'SOUSTYPE','KIZP')
  173. CALL ECMO(MTABLE,MEQUA(1:LC1),'TABLE',MTABX)
  174.  
  175. * ECRITURE DE LA TABLE DE REFERENCE
  176. CALL ECMO(MTABX,'EQPR','TABLE',MTABLE)
  177. * ECRITURE DU NOM DE LA ZONE
  178. CALL ECMM(MTABX,'NOMZONE',NOMZ)
  179. * ECRITURE DE MELEMZ
  180. CALL ECMO(MTABX,'DOMZ','TABLE',KTAB(1))
  181.  
  182. CALL ECMM(MTABX,'NOMOPER',NOM)
  183.  
  184. * ECRITURE DE LA LISTE DES ARGUMENTS
  185. IARG=0
  186. CALL ECME(MTABX,'IARG',IARG)
  187.  
  188. 110 CONTINUE
  189. CALL QUETYP(MTYP,0,IRET)
  190. IF(IRET.EQ.0)GO TO 90
  191.  
  192. C write(6,*)' MTYP=',mtyp
  193. IF(MTYP.EQ.'MOT ')THEN
  194.  
  195. CALL LIRCHA(NOM,1,IRET)
  196. C write(6,*)' NOM=',nom
  197. CALL OPTLI(IP,LMOTS(1),NOM,NBM)
  198. C write(6,*)' IP=',ip
  199. IF(IP.EQ.0)THEN
  200. IARG=IARG+1
  201. CALL ECME(MTABX,'IARG',IARG)
  202. NOMO=NOM
  203. IF(IARG.GT.9)CALL ARRET(0)
  204. WRITE(NOM,FMT='(A3,I1)')'ARG',IARG
  205. CALL ECMM(MTABX,NOM(1:4),NOMO)
  206. GO TO 111
  207.  
  208. ELSE
  209. CALL ECME(MTABX,'IARG',IARG)
  210. GO TO 2
  211. ENDIF
  212.  
  213. ELSEIF(MTYP.EQ.'CHPOINT ')THEN
  214. CALL LIROBJ('CHPOINT ',IZTAB,1,IRET)
  215. IARG=IARG+1
  216. CALL ECME(MTABX,'IARG',IARG)
  217. IF(IARG.GT.9)CALL ARRET(0)
  218. WRITE(NOM,FMT='(A3,I1)')'ARG',IARG
  219. CALL ECMO(MTABX,NOM(1:4),'CHPOINT ',IZTAB)
  220. GO TO 111
  221.  
  222. ELSEIF(MTYP.EQ.'FLOTTANT')THEN
  223. CALL LIRREE(XVAL,1,IRET)
  224. IARG=IARG+1
  225. CALL ECME(MTABX,'IARG',IARG)
  226. IF(IARG.GT.9)CALL ARRET(0)
  227. WRITE(NOM,FMT='(A3,I1)')'ARG',IARG
  228. CALL ECMF(MTABX,NOM(1:4),XVAL)
  229. GO TO 111
  230.  
  231. ELSEIF(MTYP.EQ.'ENTIER ')THEN
  232. CALL LIRENT(IENT,1,IRET)
  233. IARG=IARG+1
  234. CALL ECME(MTABX,'IARG',IARG)
  235. IF(IARG.GT.9)CALL ARRET(0)
  236. WRITE(NOM,FMT='(A3,I1)')'ARG',IARG
  237. XVAL=FLOAT(IENT)
  238. CALL ECMF(MTABX,NOM(1:4),XVAL)
  239. GO TO 111
  240.  
  241. ELSEIF(MTYP.EQ.'POINT ')THEN
  242. CALL LIROBJ('POINT',IZTAB,1,IRET)
  243. IARG=IARG+1
  244. CALL ECME(MTABX,'IARG',IARG)
  245. IF(IARG.GT.9)CALL ARRET(0)
  246. WRITE(NOM,FMT='(A3,I1)')'ARG',IARG
  247. CALL ECMO(MTABX,NOM(1:4),'POINT',IZTAB)
  248. GO TO 111
  249.  
  250. ELSE
  251. WRITE(6,*)' OBJET DE TYPE INDESIRE'
  252. WRITE(6,*)' ON ATTEND UN CHAMPOINT ou un FLOTTANT '
  253. RETURN
  254. ENDIF
  255.  
  256. 111 CONTINUE
  257. CALL ECME(MTABX,'IARG',IARG)
  258. GO TO 1
  259.  
  260.  
  261. 12 CONTINUE
  262. CALL LIRENT(IENT,1,IRET)
  263. IF(IRET.EQ.0.OR.IENT.GT.7) GOTO 90
  264. CALL ECME(MTABLE,'KTYPI',IENT)
  265. IF(IENT.GT.1) THEN
  266. CALL CRTABL(MTAB1)
  267. CALL ECMM(MTAB1,'SOUSTYPE','METHODE')
  268. CALL ECME(MTAB1,'KTYPI',IENT)
  269. CALL ECME(MTAB1,'NITMAX',2000)
  270. CALL ECMF(MTAB1,'EPSI',1.D-05)
  271. CALL ECME(MTAB1,'NPITE',10)
  272. CALL ECME(MTAB1,'NFIMPR',0)
  273. IF(IENT.GT.1.AND.IENT.LT.5) CALL ECME(MTAB1,'KSTOCK',0)
  274. CALL ECMO(MTABLE,'METHODE','TABLE',MTAB1)
  275. ENDIF
  276. GO TO 1
  277.  
  278. C BETA
  279. 14 CONTINUE
  280. TYP2='MAILLAGE'
  281. CALL ACMO(MTABD,'MACRO',TYP2,IMAC)
  282. IF(IMAC.EQ.0)THEN
  283. WRITE(6,*)' EQPR : option MACRO absente de la table domaine '
  284. RETURN
  285. ELSE
  286. CALL LIRREE(XVAL,1,IRET)
  287. IF(IRET.EQ.0)GOTO 90
  288. CALL ECME(MTABLE,'KBETA',1)
  289. CALL ECMF(MTABLE,'BETA',XVAL)
  290. ENDIF
  291. GO TO 1
  292.  
  293. C KPIMP
  294. 15 CONTINUE
  295. CALL LIRREE(XVAL,1,IRET)
  296. IF(IRET.EQ.0)GOTO 90
  297. CALL ECME(MTABLE,'KPIMP',1)
  298. CALL ECMF(MTABLE,'PIMP',XVAL)
  299. GO TO 1
  300.  
  301.  
  302.  
  303.  
  304. 90 CONTINUE
  305. SEGDES MTABLE
  306. CALL ECROBJ('TABLE',MTABLE)
  307. RETURN
  308. END
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  

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