Télécharger quesup.eso

Retour à la liste

Numérotation des lignes :

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

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