Télécharger quesup.eso

Retour à la liste

Numérotation des lignes :

  1. C QUESUP SOURCE GG250959 17/09/20 21:16:28 9554
  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. -INC CCOPTIO
  60. -INC SMCHAML
  61. -INC SMINTE
  62. -INC SMMODEL
  63. *
  64. SEGMENT INFO
  65. INTEGER INFELL(JG)
  66. ENDSEGMENT
  67. *
  68. CHARACTER*16 CONCH
  69.  
  70. *--------- Fin des déclarations ----------------------
  71.  
  72. IRET=0
  73. IRET2=0
  74. ICONST=1
  75. *
  76. MCHELM=IPCHE1
  77. SEGACT MCHELM
  78. NSOUS=ICHAML(/1)
  79. N3=INFCHE(/2)
  80. *
  81. * Recherche de l'information sur le support stockée dans INFCHE(*,6) ...
  82. *
  83. IF(N3.GE.6) THEN
  84. IRET2=INFCHE(1,6)
  85. DO 9 ISOUS=2,NSOUS
  86. IF(INFCHE(ISOUS,6).NE.IRET2) IRET2=9999
  87. 9 CONTINUE
  88. ELSE
  89. IRET2=9999
  90. ENDIF
  91. *
  92. * si le chamelem est constant sur l'element quelque soit le
  93. * support demande on est bon
  94. *
  95. DO 10 ISOUS=1,NSOUS
  96. MCHAML=ICHAML(ISOUS)
  97. SEGACT MCHAML
  98. NCOMP=IELVAL(/1)
  99. DO 20 ICOMP=1,NCOMP
  100. MELVAL=IELVAL(ICOMP)
  101. IF(MELVAL.NE.0)THEN
  102. SEGACT MELVAL
  103. IF(TYPCHE(ICOMP)(1:8).NE.'POINTEUR')THEN
  104. IPOIN=VELCHE(/1)
  105. ELSE
  106. IPOIN=IELCHE(/1)
  107. ENDIF
  108. IF(IPOIN.NE.1)THEN
  109. *pv SEGDES MELVAL,MCHAML
  110. ICONST=0
  111. GOTO 500
  112. ENDIF
  113. *pv SEGDES MELVAL
  114. ENDIF
  115. 20 CONTINUE
  116. *pv SEGDES MCHAML
  117. 10 CONTINUE
  118. *
  119. 500 CONTINUE
  120. IF (N3.LT.4) GOTO 1000
  121. IF(N3.GE.6) THEN
  122. ISUP1=INFCHE(1,6)
  123. IF (ICONST.EQ.1) GOTO 666
  124. ELSE
  125. GOTO 3000
  126. ENDIF
  127. *
  128. IFLAG=0
  129. *
  130. * CAS ISUP = 0
  131. * ------------
  132. *
  133. IF(ISUP.EQ.0)THEN
  134. IF(N3.GE.6)ISUP1=INFCHE(1,6)
  135. DO 1 ISOUS=1,NSOUS
  136. * write (6,*) ' isous n3 infche4 ',isous,n3,infche(isous,4)
  137. IF (INFCHE(ISOUS,4).EQ.0) GOTO 1
  138. IF (N3.GE.6) THEN
  139. INFCH=INFCHE(ISOUS,6)
  140. * write (6,*) ' infch isup1 ',infch,isup1
  141. IF (INFCH.EQ.1) GOTO 1
  142. IF (INFCH.NE.ISUP1) THEN
  143. MINTE=INFCHE(1,4)
  144. MINTE1=INFCHE(ISOUS,4)
  145. SEGACT MINTE
  146. SEGACT MINTE1
  147. NBPGAU=POIGAU(/1)
  148. NBPGA1=MINTE1.POIGAU(/1)
  149. *pv SEGDES,MINTE,MINTE1
  150. IF(NBPGAU.EQ.NBPGA1)THEN
  151. IFLAG=IFLAG+1
  152. ELSE
  153. GOTO 2000
  154. ENDIF
  155. ELSE
  156. IFLAG=IFLAG+1
  157. ENDIF
  158. ELSE
  159. GOTO 3000
  160. ENDIF
  161. 1 CONTINUE
  162. *
  163. * TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT
  164. *
  165. IF (IFLAG.EQ.0) GOTO 1000
  166. IF (IFLAG.EQ.NSOUS) THEN
  167. IF(ISUP.EQ.0) THEN
  168. IRET=ISUP1
  169. ENDIF
  170. GOTO 666
  171. ELSE
  172. GOTO 2000
  173. ENDIF
  174. *
  175. * CAS ISUP > 0
  176. * ------------
  177. * DANS CE CAS CE SONT LES ZONES DU MODELE QUI PILOTENT
  178. *
  179. ELSE
  180. ISUP1=ISUP
  181. *
  182. * ACTIVATION DU MODELE
  183. *
  184. MMODEL=IPMODE
  185. SEGACT MMODEL
  186. NSOUM=KMODEL(/1)
  187. DO 11 ISOUM=1,NSOUM
  188. IMODEL=KMODEL(ISOUM)
  189. SEGACT IMODEL
  190. MELE=NEFMOD
  191. if ((mele.eq.22).or.(mele.eq.259)) then
  192. segdes imodel
  193. go to 11
  194. endif
  195. *
  196. * BOUCLE SUR LES ZONES DU CHAMELEM
  197. *
  198. DO 2 ISOUS=1,NSOUS
  199. CONCH=CONCHE(ISOUS)
  200. IPMAIL=IMACHE(ISOUS)
  201. * write (6,*) ' isous,imamod ipmail conch conmod infche4 ',
  202. * > isous,imamod,ipmail,conch,conmod,infche(isous,4)
  203. IF(IMAMOD.NE.IPMAIL.OR.CONCH.NE.CONMOD)GOTO 2
  204.  
  205. IF (INFCHE(ISOUS,4).EQ.0) GOTO 2
  206. *
  207. IF (N3.GE.6) THEN
  208. INFCH=INFCHE(ISOUS,6)
  209. IF (INFCH.EQ.1) GOTO 2
  210. IF (INFCH.NE.ISUP1) THEN
  211. IF(ISUP1.EQ.6)THEN
  212. CALL TSHAPE(MELE,'GAUSS',IPMIN1)
  213. ELSE
  214. If(infmod(/1).lt.2+isup1) then
  215. CALL ELQUOI(MELE,0,ISUP1,IPINF,IMODEL)
  216. IF(IERR.NE.0) THEN
  217. IRET=9999
  218. SEGDES IMODEL
  219. SEGDES MMODEL
  220. GOTO 666
  221. ENDIF
  222. INFO=IPINF
  223. IPMIN1=INFELL(11)
  224. segsup info
  225. else
  226. ipmin1=infmod(2+isup1)
  227. endif
  228.  
  229. ENDIF
  230. MINTE=INFCHE(ISOUS,4)
  231. MINTE1=IPMIN1
  232. SEGACT MINTE
  233. SEGACT MINTE1
  234. NBPGAU=POIGAU(/1)
  235. NBPGA1=MINTE1.POIGAU(/1)
  236. IF(NBPGAU.EQ.NBPGA1)THEN
  237. IRT=1
  238. ELSE
  239. IRT=0
  240. ENDIF
  241. *pv SEGDES MINTE,MINTE1
  242. IF(IRT.EQ.1)THEN
  243. IFLAG=IFLAG+1
  244. ELSE
  245. *pv SEGDES IMODEL
  246. *pv SEGDES MMODEL
  247. GOTO 2000
  248. ENDIF
  249. ELSE
  250. IFLAG=IFLAG+1
  251. ENDIF
  252. ELSE
  253. *pv SEGDES IMODEL
  254. *pv SEGDES MMODEL
  255. GOTO 3000
  256. ENDIF
  257. 2 CONTINUE
  258. *pv SEGDES IMODEL
  259. 11 CONTINUE
  260. *pv SEGDES MMODEL
  261. *
  262. * TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT
  263. *
  264. * write (6,*) ' quesup iflag isup nsous ',iflag,isup,nsous
  265. IF (IFLAG.EQ.0) GOTO 1000
  266. IF (IFLAG.EQ.NSOUS) THEN
  267. IF(ISUP.EQ.0) THEN
  268. IRET=ISUP1
  269. ENDIF
  270. GOTO 666
  271. ELSE
  272. GOTO 2000
  273. ENDIF
  274. ENDIF
  275. *
  276. 1000 CONTINUE
  277. *
  278. * IPCHE1 EST AUX NOEUDS
  279. *
  280. IRET=1
  281. IF (ISUP.EQ.1) IRET=0
  282. IF (ICOND.EQ.1.AND.IRET.EQ.1.AND.ISUP.NE.0) GOTO 2000
  283. GOTO 666
  284. *
  285. 2000 CONTINUE
  286. *
  287. IF(ISUP.NE.0)THEN
  288. *
  289. * IPCHE1 EST SUR UN AUTRE SUPPORT QUE CELUI VOULU ET PAS AUX NOEUDS
  290. *
  291. * ==> MESSAGE D'ERREUR POUR QUE L'ON DONNE LE CHAMELEM SUR UN
  292. * SUPPORT CORRECT
  293. *
  294. MOTERR(1:8)=TITCHE
  295. CALL ERREUR(124)
  296. ELSE
  297. *
  298. * LES DIFFERENTS SOUS-ZONES DU CHAMELEM ONT DES POINTS SUPPORTS DIFFERENTS
  299. *
  300. CALL ERREUR(560)
  301. ENDIF
  302. SEGDES MCHELM
  303. IRET=9999
  304. RETURN
  305. *
  306. 3000 CONTINUE
  307. *
  308. * IPCHE1 A UN POINTEUR SUR UN MINTE <> 0 MAIS L'INFCHE(..,6)
  309. * N'EST PAS RENSEIGNE (NE DOIT PAS ARRIVER NORMALEMENT)
  310. *
  311. IRET=9999
  312. CALL ERREUR(53)
  313. *
  314. 666 CONTINUE
  315. *pv SEGDES MCHELM
  316. RETURN
  317. END
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  

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