Télécharger eqpr.eso

Retour à la liste

Numérotation des lignes :

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

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