Télécharger quesup.eso

Retour à la liste

Numérotation des lignes :

quesup
  1. C QUESUP SOURCE CB215821 20/07/29 21:16:08 10668
  2. SUBROUTINE QUESUP (IPMODE,IPCHE1,ISUP,ICOND,IRET,IRET2)
  3. *______________________________________________________________________
  4. *
  5. * VERIFICATION DU LIEU SUPPORT DES MCHAML
  6. *
  7. * IPMODE POINTEUR SUR UN OBJET MODELE (UTILISE UNIQUEMENT QUAND ISUP>0)
  8. * DESACTIVE EN SORTIE
  9. * IPCHE1 POINTEUR SUR LE MCHAML DONT ON SOUHAITE VERIFIER LE SUPPORT
  10. * (LIEU DU MINTE)
  11. * ISUP > 0 :
  12. *
  13. * ISUP = 1 ON SOUHAITE QUE IPCHE1 SOIT AUX NOEUDS
  14. * = 2 ON SOUHAITE QUE IPCHE1 SOIT AUX CENTRE DE GRAVITE
  15. * = 3 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR
  16. * LA RIGIDITE
  17. * = 4 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR
  18. * LA MASSE
  19. * = 5 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR
  20. * LES CONTRAINTES
  21. * ISUP = 0 ON VEUDRAIT CONNAITRE LE SUPPORT
  22. *
  23. * ICOND = 0 SI LE MCHAML PEUT ETRE SUR LE SUPPORT DEMANDE OU AUX
  24. * NOEUDS(UTILISE UNIQUEMENT QUAND ISUP >0)
  25. * 1 SI LE MCHAML DOIT ETRE IMPERATIVEMENT SUR LE SUPPORT
  26. * VOULU (CAS NOTAMENT DES MATRICE DE HOOKES ET DES
  27. * DES MATRICES DE HOOKES TANGENTES)
  28. * DANS LE CAS ISUP > 0
  29. *
  30. * IRET = 1 IPCHE1 SE TROUVE AUX NOEUDS
  31. * = 0 IPCHE1 EST BIEN SUR LE SUPPORT DEMANDE
  32. * = 9999 LE SUPPORT DE UNE OU PLUSIEURS SOUS ZONE N'EST
  33. * PAS LE BON
  34. * DANS LE CAS ISUP = 0
  35. *
  36. * IRET > 0 IL DONNE LE NUMERO DU SUPPORT
  37. * = 0 LE CHAMP EST CONSTANT
  38. * = 9999 LE CHAMELEM N'EST PAS HOMOGENE AU NIVEAU SUPPORT
  39. *
  40. * DANS TOUS LES CAS (ISUP >= 0)
  41. *
  42. * IRET2 > 0 IL DONNE LE NUMERO DU SUPPORT
  43. * = 9999 LE CHAMELEM N'EST PAS HOMOGENE AU NIVEAU SUPPORT
  44. * OU SI LE TABLEAU INFCHE NE CONTIENT PAS CETTE
  45. * INFORMATION
  46. *
  47. * REMARQUE : SI IPCHE1 EST AUX NOEUDS LE PASSAGE DES VALEURS SUR LE
  48. * SUPPORT VOULU SE FAIT DANS VALCHE ET/OU VALMEL SAUF DANS
  49. * LE CAS DES MATRICE DE HOOKES
  50. *
  51. * CAMPENON JM LE 02/91
  52. *
  53. *pv on ne desactivee pas car ca va resservir tres bientot
  54. *
  55. *_______________________________________________________________________
  56. *
  57. IMPLICIT INTEGER(I-N)
  58. IMPLICIT REAL*8(A-H,O-Z)
  59.  
  60. -INC PPARAM
  61. -INC CCOPTIO
  62. -INC SMCHAML
  63. -INC SMINTE
  64. -INC SMMODEL
  65. *
  66. SEGMENT INFO
  67. INTEGER INFELL(JG)
  68. ENDSEGMENT
  69. *
  70. CHARACTER*(NCONCH) CONCH
  71.  
  72. *--------- Fin des déclarations ----------------------
  73.  
  74. IRET=0
  75. IRET2=0
  76. ICONST=1
  77. *
  78. MCHELM=IPCHE1
  79. NSOUS=ICHAML(/1)
  80. N3=INFCHE(/2)
  81. *
  82. * Recherche de l'information sur le support stockée dans INFCHE(*,6) ...
  83. *
  84. IF(N3.GE.6) THEN
  85. IRET2=INFCHE(1,6)
  86. DO 9 ISOUS=2,NSOUS
  87. IF(INFCHE(ISOUS,6).NE.IRET2) IRET2=9999
  88. 9 CONTINUE
  89. ELSE
  90. IRET2=9999
  91. ENDIF
  92. *
  93. * si le chamelem est constant sur l'element quelque soit le
  94. * support demande on est bon
  95. *
  96. DO 10 ISOUS=1,NSOUS
  97. MCHAML=ICHAML(ISOUS)
  98. NCOMP=IELVAL(/1)
  99. DO 20 ICOMP=1,NCOMP
  100. MELVAL=IELVAL(ICOMP)
  101. IF(MELVAL.NE.0)THEN
  102. IF(TYPCHE(ICOMP)(1:8).NE.'POINTEUR')THEN
  103. IPOIN=VELCHE(/1)
  104. ELSE
  105. IPOIN=IELCHE(/1)
  106. ENDIF
  107. IF(IPOIN.NE.1)THEN
  108. ICONST=0
  109. GOTO 500
  110. ENDIF
  111. ENDIF
  112. 20 CONTINUE
  113. 10 CONTINUE
  114. *
  115. 500 CONTINUE
  116. IF (N3.LT.4) GOTO 1000
  117. IF(N3.GE.6) THEN
  118. ISUP1=INFCHE(1,6)
  119. IF (ICONST.EQ.1) GOTO 666
  120. ELSE
  121. GOTO 3000
  122. ENDIF
  123. *
  124. IFLAG=0
  125. *
  126. * CAS ISUP = 0
  127. * ------------
  128. *
  129. IF(ISUP.EQ.0)THEN
  130. IF(N3.GE.6)ISUP1=INFCHE(1,6)
  131. DO 1 ISOUS=1,NSOUS
  132. * write (6,*) ' isous n3 infche4 ',isous,n3,infche(isous,4)
  133. IF (INFCHE(ISOUS,4).EQ.0) GOTO 1
  134. IF (N3.GE.6) THEN
  135. INFCH=INFCHE(ISOUS,6)
  136. * write (6,*) ' infch isup1 ',infch,isup1
  137. IF (INFCH.EQ.1) GOTO 1
  138. IF (INFCH.NE.ISUP1) THEN
  139. MINTE=INFCHE(1,4)
  140. MINTE1=INFCHE(ISOUS,4)
  141. NBPGAU=POIGAU(/1)
  142. NBPGA1=MINTE1.POIGAU(/1)
  143. IF(NBPGAU.EQ.NBPGA1)THEN
  144. IFLAG=IFLAG+1
  145. ELSE
  146. GOTO 2000
  147. ENDIF
  148. ELSE
  149. IFLAG=IFLAG+1
  150. ENDIF
  151. ELSE
  152. GOTO 3000
  153. ENDIF
  154. 1 CONTINUE
  155. *
  156. * TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT
  157. *
  158. IF (IFLAG.EQ.0) GOTO 1000
  159. IF (IFLAG.EQ.NSOUS) THEN
  160. IF(ISUP.EQ.0) THEN
  161. IRET=ISUP1
  162. ENDIF
  163. GOTO 666
  164. ELSE
  165. GOTO 2000
  166. ENDIF
  167. *
  168. * CAS ISUP > 0
  169. * ------------
  170. * DANS CE CAS CE SONT LES ZONES DU MODELE QUI PILOTENT
  171. *
  172. ELSE
  173. ISUP1=ISUP
  174. *
  175. * ACTIVATION DU MODELE
  176. *
  177. MMODEL=IPMODE
  178. NSOUM =KMODEL(/1)
  179. INBR =0
  180. DO 11 ISOUM=1,NSOUM
  181. IMODEL=KMODEL(ISOUM)
  182. MELE =NEFMOD
  183. if ((mele.eq.22).or.(mele.eq.259)) then
  184. goto 11
  185. endif
  186.  
  187. *
  188. * BOUCLE SUR LES ZONES DU CHAMELEM
  189. *
  190. DO 2 ISOUS=1,NSOUS
  191. CONCH =CONCHE(ISOUS)
  192. IPMAIL=IMACHE(ISOUS)
  193. * write (6,*) ' isous,imamod ipmail conch conmod infche4 ',
  194. * > isous,imamod,ipmail,conch,conmod,infche(isous,4)
  195. IF(IMAMOD.NE.IPMAIL.OR.CONCH.NE.CONMOD)GOTO 2
  196. IF(INFCHE(ISOUS,4).EQ.0) GOTO 2
  197. *
  198. IF (N3.GE.6) THEN
  199. INFCH=INFCHE(ISOUS,6)
  200. IF (INFCH.EQ.1) GOTO 2
  201. INBR = INBR + 1
  202.  
  203. IF (INFCH.NE.ISUP1) THEN
  204. IF(ISUP1.EQ.6)THEN
  205. CALL TSHAPE(MELE,'GAUSS',IPMIN1)
  206.  
  207. ELSE
  208. If(infmod(/1).lt.2+isup1) then
  209. CALL ELQUOI(MELE,0,ISUP1,IPINF,IMODEL)
  210. IF(IERR.NE.0) THEN
  211. IRET=9999
  212. GOTO 666
  213. ENDIF
  214. INFO=IPINF
  215. IPMIN1=INFELL(11)
  216. segsup info
  217.  
  218. else
  219. ipmin1=infmod(2+isup1)
  220. endif
  221. ENDIF
  222.  
  223. MINTE=INFCHE(ISOUS,4)
  224. MINTE1=IPMIN1
  225. NBPGAU=POIGAU(/1)
  226. NBPGA1=MINTE1.POIGAU(/1)
  227.  
  228. IF(NBPGAU.EQ.NBPGA1)THEN
  229. IRT=1
  230. ELSE
  231. IRT=0
  232. ENDIF
  233.  
  234. IF(IRT.EQ.1)THEN
  235. IFLAG=IFLAG+1
  236. ELSE
  237. GOTO 2000
  238. ENDIF
  239.  
  240. ELSE
  241. IFLAG=IFLAG+1
  242. ENDIF
  243.  
  244. ELSE
  245. GOTO 3000
  246. ENDIF
  247. 2 CONTINUE
  248. 11 CONTINUE
  249. *
  250. * TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT
  251. *
  252. * write (6,*) ' quesup iflag isup nsous ',iflag,isup,nsous
  253. IF (IFLAG.EQ.0) GOTO 1000
  254. IF (IFLAG.EQ.INBR) THEN
  255. IF(ISUP.EQ.0) THEN
  256. IRET=ISUP1
  257. ENDIF
  258. GOTO 666
  259. ELSE
  260. GOTO 2000
  261. ENDIF
  262. ENDIF
  263. *
  264. 1000 CONTINUE
  265. *
  266. * IPCHE1 EST AUX NOEUDS
  267. *
  268. IRET=1
  269. IF (ISUP.EQ.1) IRET=0
  270. IF (ICOND.EQ.1.AND.IRET.EQ.1.AND.ISUP.NE.0) GOTO 2000
  271. GOTO 666
  272. *
  273. 2000 CONTINUE
  274. *
  275. IF(ISUP.NE.0)THEN
  276. *
  277. * IPCHE1 EST SUR UN AUTRE SUPPORT QUE CELUI VOULU ET PAS AUX NOEUDS
  278. *
  279. * ==> MESSAGE D'ERREUR POUR QUE L'ON DONNE LE CHAMELEM SUR UN
  280. * SUPPORT CORRECT
  281. *
  282. MOTERR(1:8)=TITCHE
  283. CALL ERREUR(124)
  284. ELSE
  285. *
  286. * LES DIFFERENTS SOUS-ZONES DU CHAMELEM ONT DES POINTS SUPPORTS DIFFERENTS
  287. *
  288. CALL ERREUR(560)
  289. ENDIF
  290. IRET=9999
  291. RETURN
  292. *
  293. 3000 CONTINUE
  294. *
  295. * IPCHE1 A UN POINTEUR SUR UN MINTE <> 0 MAIS L'INFCHE(..,6)
  296. * N'EST PAS RENSEIGNE (NE DOIT PAS ARRIVER NORMALEMENT)
  297. *
  298. IRET=9999
  299. CALL ERREUR(53)
  300. *
  301. 666 CONTINUE
  302. END
  303.  
  304.  
  305.  
  306.  

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