Télécharger cochpo.eso

Retour à la liste

Numérotation des lignes :

  1. C COCHPO SOURCE CHAT 05/01/12 22:12:25 5004
  2. SUBROUTINE COCHPO(I0,I1,ITAI,ITAF)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  6. C C CE SUBROUTINE VERIFIE QUE LES CHPOINTI0 ET I1 SONT BIEN IDENTIQUE
  7. C C EVENTUELLEMENT IL REMET LA LISTE ITAI SOUS LA FORME CORRESPONDANT
  8. C C A I0
  9. C C ECRIT PAR FARVACQUE
  10. C C APPELE PAR :FUSOLU
  11. C C APPELLE ERREUR(60)
  12. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13. C
  14. -INC SMELEME
  15. -INC CCOPTIO
  16. -INC SMCHPOI
  17. -INC SMSOLUT
  18. -INC SMCOORD
  19. C
  20. CHARACTER*4 ICOMP
  21. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  22. SEGMENT ICPRR(XCOOR(/1)/(IDIM+1))
  23. SEGMENT ITRAV(4,NSOUP)
  24. SEGMENT ITRACO(NC)
  25. C
  26. C ITRAV(1,I)=NPOIN (NBRE DE POINTS DANS LE IEME SOUPO)
  27. C ITRAV(2,I)=J : AU MSOUPO I CORRESPOND LE MSOUP1 J
  28. C ITRAV(3,I)=0 : AUCUN CHANGEMENT A APPLIQUER AU MSOUPO I (SINON =1)
  29. C ITRAV(4,I)=ITRACO : CONTIENT LE POINTEUR DU SEGMENT ITRACO
  30. C CCC ITRACO(J)=K : LA COMPOSANTE A LA POSITION J DANS MCHPO1 EST A LA
  31. C CCC POSITION K DANS MCHPOI
  32. C CCC MCHPOI SERA LA CONFIGURATION FINALE
  33. C
  34. MCHPOI=I0
  35. MCHPO1=I1
  36. SEGACT MCHPO1,MCHPOI
  37. NSOUP=MCHPO1.IPCHP(/1)
  38. IF(NSOUP.EQ.IPCHP(/1)) GO TO 1
  39. C LES 2 CHPOINTS DOIVENT AVOIR LE MEME NOMBRE DE SOUS CHAMPS
  40. CALL ERREUR(60)
  41. GO TO 5000
  42. 1 CONTINUE
  43. SEGINI ITRAV
  44. SEGINI ICPR
  45. SEGINI ICPRR
  46. ICPR1=XCOOR(/1)/(IDIM+1)
  47. DO 10 I=1,ICPR1
  48. 10 ICPR(I)=0
  49. C
  50. C *** BOUCLE SUR LES SOUPO DE MCHPOI
  51. C *** DANS ICPR(I) ON MET LE NUMERO DU SOUPO OU SE TROUVE LE POINT I
  52. C *** ICPRR(I)=K SIGNIFIE QUE I EST LE KIEME POINT DU SOUPO
  53. C
  54. DO 2 I=1,NSOUP
  55. MSOUPO=IPCHP(I)
  56. SEGACT MSOUPO
  57. MELEME=IGEOC
  58. SEGACT MELEME
  59. NPOIN=NUM(/2)
  60. ITRAV(1,I)=NPOIN
  61. DO 3 IPP=1,NPOIN
  62. J=NUM(1,IPP)
  63. ICPR(J)=I
  64. ICPRR(J)=IPP
  65. 3 CONTINUE
  66. SEGDES MELEME,MSOUPO
  67. 2 CONTINUE
  68. C
  69.  
  70. ICHPOI=MCHPOI
  71. CALL NUHARM(ICHPOI,IFO,IHAR)
  72. MCHPOI=ICHPOI
  73. C IFO=1 TOUTES LES HARMONIQUES SONT IDENTIQUES ...
  74. C ON PEUT METTRE ENSEMBLE DU MODE N ET DU MODE M
  75. C
  76. C*** BOUCLE SUR LES MSOUP1 DE MCHPO1
  77. C
  78. DO 4 I=1,NSOUP
  79. MSOUP1=MCHPO1.IPCHP(I)
  80. SEGACT MSOUP1
  81. MELEME=MSOUP1.IGEOC
  82. SEGACT MELEME
  83. NPOIN=NUM(/2)
  84. IP1=NUM(1,1)
  85. ISOUPO=ICPR(IP1)
  86. IF(ICPRR(IP1).NE.1) ITRAV(3,ISOUPO)=1
  87. IF(ISOUPO.NE.0) GO TO 5
  88. C POINT NON COMMUN AUX 2 CHPOINT
  89. CALL ERREUR(60)
  90. GO TO 5000
  91. C
  92. 5 CONTINUE
  93. IF(NPOIN.EQ.ITRAV(1,ISOUPO)) GO TO 6
  94. C LES 2 SOUPO N ONT PAS LE MEME NOMBRE DE POINTS
  95. CALL ERREUR(60)
  96. GO TO 5000
  97. C
  98. 6 CONTINUE
  99. ITRAV(2,ISOUPO)=I
  100. IF(NPOIN.EQ.1) GO TO 9
  101. DO 8 IPP=2,NPOIN
  102. IP1=NUM(1,IPP)
  103. IF(ICPRR(IP1).NE.IPP) ITRAV(3,ISOUPO)=1
  104. IF(ICPR(IP1).EQ.ISOUPO)GO TO 8
  105. C POINT NON COMMUN AUX 2 MSOUPO
  106. CALL ERREUR(60)
  107. GO TO 5000
  108. 8 CONTINUE
  109. 9 CONTINUE
  110. MSOUPO=IPCHP(ISOUPO)
  111. SEGACT MSOUPO
  112. NC=NOCOMP(/2)
  113. IF(MSOUP1.NOCOMP(/2).EQ.NC) GO TO 12
  114. CALL ERREUR(60)
  115. C PAS LE MEME NOMBRE DE COMPOSANTE
  116. GO TO 5000
  117. 12 CONTINUE
  118. SEGINI ITRACO
  119. DO 13 IC=1,NC
  120. ICOMP=MSOUP1.NOCOMP(IC)
  121. IHARM=MSOUP1.NOHARM(IC)
  122. DO 14 ICC=1,NC
  123. IF(NOCOMP(ICC).NE.ICOMP) GO TO 14
  124. IF(IFO.NE.1.AND.NOHARM(ICC).NE.IHARM) GO TO 14
  125. IF(IC.NE.ICC)ITRAV(3,ISOUPO)=1
  126. ITRACO(IC)=ICC
  127. GO TO 13
  128. 14 CONTINUE
  129. CALL ERREUR(60)
  130. C N OND PAS(LS MEMES COMPOSANTES
  131. GO TO 5000
  132. 13 CONTINUE
  133. ITRAV(4,ISOUPO)=ITRACO
  134. SEGDES ITRACO
  135. C
  136. SEGDES MSOUPO,MELEME,MSOUP1
  137. 4 CONTINUE
  138. SEGDES MCHPO1
  139. C
  140. C
  141. DO 30 I=1,NSOUP
  142. IF(ITRAV(3,I).NE.0) GO TO 41
  143. 30 CONTINUE
  144. C IL N Y A AUCUNE MODIF A FAIRE SUR LES MPOVAL
  145. C
  146. DO 31 I=1,NSOUP
  147. IF(ITRAV(2,I).EQ.I) GO TO 31
  148. GO TO 41
  149. 31 CONTINUE
  150. C IL N Y A AUCUNE MODIF A FAIRE ON SORT
  151. ITAF=ITAI
  152. GO TO 60
  153. C
  154. 41 CONTINUE
  155. C *** SI IVAL=0 IL FAUT SEULEMENT PERMUTER LES MSOUP1
  156. C *** SI IVAL=1 ON DOIT REMPLACER LES MSOUP1 PAR DES MSOUP2
  157. C
  158. MSOLE1=ITAI
  159. SEGACT MSOLE1
  160. LTAB=MSOLE1.ISOLEN(/1)
  161. N=LTAB
  162. SEGINI MSOLEN
  163. DO 42 IT=1,LTAB
  164. ISOLEN(IT)=MSOLE1.ISOLEN(IT)
  165. 42 CONTINUE
  166. SEGDES MSOLE1
  167. C
  168. DO 50 IT=1,LTAB
  169. MCHPO1=ISOLEN(IT)
  170. SEGACT MCHPO1
  171. NSOUPO=NSOUP
  172. NAT=MCHPO1.JATTRI(/1)
  173. SEGINI MCHPO2
  174. MCHPO2.IFOPOI=IFOPOI
  175. * on reprend les meme attributs
  176. DO 101 INAT=1,NAT
  177. MCHPO2.JATTRI(INAT) = MCHPO1.JATTRI(INAT)
  178. 101 CONTINUE
  179. *
  180. DO 52 IS=1,NSOUPO
  181. MSOUP1=MCHPO1.IPCHP(ITRAV(2,IS))
  182. IF(ITRAV(3,IS).NE.0) GO TO 53
  183. MCHPO2.IPCHP(IS)=MSOUP1
  184. GO TO 52
  185. 53 CONTINUE
  186. MSOUPO=IPCHP(IS)
  187. SEGACT MSOUPO,MSOUP1
  188. NC=MSOUP1.NOCOMP(/2)
  189. SEGINI MSOUP2
  190. MSOUP2.IGEOC=IGEOC
  191. DO 54 IC=1,NC
  192. MSOUP2.NOCOMP(IC)=NOCOMP(IC)
  193. MSOUP2.NOHARM(IC)=NOHARM(IC)
  194. IF(IFO.EQ.1) MSOUP2.NOHARM(IC)=MSOUP1.NOHARM(IC)
  195. 54 CONTINUE
  196. MELEME=MSOUP1.IGEOC
  197. SEGACT MELEME
  198. MPOVA1=MSOUP1.IPOVAL
  199. SEGACT MPOVA1
  200. N=MPOVA1.VPOCHA(/1)
  201. NC=MPOVA1.VPOCHA(/2)
  202. SEGINI MPOVAL
  203. ITRACO=ITRAV(4,IS)
  204. SEGACT ITRACO
  205. DO 20 IN=1,N
  206. DO 20 IC=1,NC
  207. IP1=ICPRR(NUM(1,IN))
  208. VPOCHA(IP1,ITRACO(IC))=MPOVA1.VPOCHA(IN,IC)
  209. 20 CONTINUE
  210. SEGDES ITRACO
  211. SEGDES MPOVA1,MPOVAL,MELEME
  212. MSOUP2.IPOVAL=MPOVAL
  213. SEGDES MSOUP2,MSOUP1,MSOUPO
  214. MCHPO2.IPCHP(IS)=MSOUP2
  215. 52 CONTINUE
  216. SEGDES MCHPO2,MCHPO1
  217. ISOLEN(IT)=MCHPO2
  218. 50 CONTINUE
  219. SEGDES MSOLEN
  220. ITAF=MSOLEN
  221. C
  222. 60 CONTINUE
  223. DO 58 I=1,NSOUP
  224. ITRACO=ITRAV(4,I)
  225. SEGSUP ITRACO
  226. 58 CONTINUE
  227. SEGSUP ITRAV
  228. SEGSUP ICPR,ICPRR
  229. SEGDES MCHPOI
  230. 5000 CONTINUE
  231. RETURN
  232. END
  233.  
  234.  

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