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

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