Télécharger muchp1.eso

Retour à la liste

Numérotation des lignes :

  1. C MUCHP1 SOURCE CB215821 15/02/27 21:15:04 8417
  2. SUBROUTINE MUCHP1(IPOI1,IPOI2,LMOT1,LMOT2,LMOT3,IEPS,IRET)
  3. C=======================================================================
  4. C
  5. C entree
  6. C ipoi1=chpoint
  7. C ipoi2=chpoint
  8. C lmot1=liste de mots1
  9. C lmot2=liste de mots2
  10. C lmot3=liste de mots3
  11. C sorties
  12. C iret = pointeur sur chpoint resultant
  13. C = 0 sinon (un message d erreur est alors imprime )
  14. C
  15. C
  16. C=======================================================================
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT REAL*8(A-H,O-Z)
  19. -INC SMCHPOI
  20. -INC CCOPTIO
  21. -INC SMELEME
  22. -INC SMLMOTS
  23. -INC SMCOORD
  24. C le tableau icpr contient la mise en ordre des 3 chpoint
  25. SEGMENT ICPR
  26. C nbre harm. comp points chpoints
  27. REAL*8 VALCPR(XCOOR(/1)/(IDIM+1),NCOMP1,NHAR)
  28. ENDSEGMENT
  29. C nocmp1 et le nombre de composante dans chaque listmot
  30. C nhar est le nombre d'harmonique de Fourrier présent
  31. C ce segment contient les numéro des différents harmoniques trouvées
  32. C et l'inversion du tableau
  33. SEGMENT NUMHAR(NHAR)
  34. SEGMENT IHARNU(NVHAR)
  35. C ce tableau sert de correspondance entre les composantes des liste mot
  36. C et celles des champ point pour chaque sous zone
  37. SEGMENT ICOR1(NCOMP1)
  38. SEGMENT ICOR2(NCOMP1)
  39. C
  40. C ces segment servent au moment de l'assemblage du nouveau chpoint
  41. C celui stocke le nombre de sous zone du nouveau chpoint
  42. SEGMENT JCHACO(4,NSOUP1)
  43. C indice 1 et 2 voir muchpo2 , 3 nombre de pts , 4 nbre de composante
  44. C kchaco donne l'adresse dans jchaco de la sous zone
  45. SEGMENT KCHACO(NSOUPO)
  46. SEGMENT MCORES
  47. C correspondence comp listmot comp sous zone
  48. INTEGER ICOR3(NCOMP1,NSOUPO)
  49. C indice 1 contient sum 2**i si i présent
  50. C indice 2 contient le nombre de i present
  51. INTEGER KCOMP(2,NSOUPO)
  52. INTEGER KHARM(NSOUPO)
  53. ENDSEGMENT
  54.  
  55.  
  56. LOGICAL IVCHPO
  57.  
  58.  
  59. C
  60. C ce tableau contient les pointeurs des deux champ point et des listemots
  61. DIMENSION ICHP(2),ILMO(2),NR(2)
  62. CHARACTER*4 MOTCLE(3),MONATU(1)
  63. DATA MOTCLE/'INDE','DIFF','DISC'/
  64. DATA MONATU/'NATU'/
  65. C
  66. C executable
  67. C verification de la dimension des listmots
  68. MLMOT1=LMOT1
  69. MLMOT2=LMOT2
  70. MLMOT3=LMOT3
  71. SEGACT MLMOT1,MLMOT2,MLMOT3
  72. NCOMP1 = MLMOT1.MOTS(/2)
  73. NCOMP2 = MLMOT2.MOTS(/2)
  74. NCOMP3 = MLMOT3.MOTS(/2)
  75. IF (NCOMP1.NE.NCOMP2.OR.NCOMP3.NE.NCOMP1) THEN
  76. C erreur dans la dimension des lismots
  77. CALL ERREUR(854)
  78. RETURN
  79. SEGDES MLMOT1,MLMOT2,MLMOT3
  80. RETURN
  81. ENDIF
  82. C determination du nombre d'harmonique de Fourrier
  83. C expédition rapide du cas sans harmonique
  84. NR(1) = 0
  85. NR(2) = 0
  86. ILMO(1)=LMOT1
  87. ILMO(2)=LMOT2
  88. ICHP(1)= IPOI1
  89. ICHP(2)= IPOI2
  90. C
  91. MCHPO1 = IPOI1
  92. MCHPO2 = IPOI2
  93. SEGACT MCHPO1,MCHPO2
  94. NHAR = 1
  95. NSUM = 0
  96. C boucle sur les 2 champoints
  97. DO 300 K=1,2
  98. MCHPO1 = ICHP(K)
  99. DO 200 I=1,MCHPO1.IPCHP(/1)
  100. MSOUPO = MCHPO1.IPCHP(I)
  101. SEGACT MSOUPO
  102. MELEME = IGEOC
  103. SEGACT MELEME
  104. NR(K) = NR(K) + NUM(/2)
  105. SEGDES MELEME
  106. DO 100 J=1,NOHARM(/1)
  107. NSUM = NSUM + NOHARM(J)
  108. 100 CONTINUE
  109. 200 CONTINUE
  110. 300 CONTINUE
  111. C
  112. C combien y a t'il d'harmoniques ?
  113. C
  114. IF (NSUM .NE. 0) THEN
  115. C il y en a plusieurs
  116. C write(6,*) 'Appel de noharm'
  117. CALL NHARMO(IPOI1,IPOI2,NHAR,NUMHAR,NMIN,IHARNU)
  118. NVHAR=IHARNU(/1)
  119. ELSE
  120. C cas simple toutes les harmoniques sont nulles
  121. NHAR = 1
  122. NVHAR= 1
  123. SEGINI NUMHAR,IHARNU
  124. NUMHAR(1)=0
  125. IHARNU(1)=1
  126. NMIN=0
  127. ENDIF
  128. C
  129. C write(6,*) 'points',XCOOR(/1)/(IDIM+1),'Comp',ncomp1,'nhar',nhar
  130. C
  131. C initialisation du tableau
  132. SEGINI ICPR
  133. C ordre des opérations
  134. C cela va dépendre des remplissage respectifs NR1 et NR2
  135. C
  136. NRR1 = MAX(NR(1),NR(2))
  137. NRR2 = MIN(NR(1),NR(2))
  138. DNRR1 = REAL(NRR1)
  139. DNRR2 = REAL(NRR2)
  140. TAUX = DNRR2 / (DNRR1+0.1)
  141. C write(6,*) 'Taux de remplissage',taux
  142. C on classe les champ point dans l'ordre de taille
  143. IF ((NRR1.NE.NR(1).AND.TAUX.LT.0.5).OR.
  144. & (NRR1.EQ.NR(1).AND.TAUX.GE.0.5)) THEN
  145. C write(6,*) 'Inversion de l ordre des champoints'
  146. C write(6,*) 'Taux de remplissage' ,taux
  147. IDUM1 = ICHP(1)
  148. IDUM2 = ILMO(1)
  149. ICHP(1)=ICHP(2)
  150. ILMO(1)=ILMO(2)
  151. ICHP(2)=IDUM1
  152. ILMO(2)=IDUM2
  153. IVCHPO=.TRUE.
  154. ELSE
  155. IVCHPO=.FALSE.
  156. ENDIF
  157. C remplissage du tableau en bouclant sur les champ par points
  158. C on boucle sur les deux champ point
  159. C pour chaque sous zone on établi la correspondance de composantes du
  160. C liste mots vers les nom de composantes de la sous zone
  161. SEGINI ICOR1,ICOR2
  162. C pseudo boucle sur les champ points
  163. MCHPOI = ICHP(1)
  164.  
  165. MLMOTS = ILMO(1)
  166. DO 900 J=1,IPCHP(/1)
  167. MSOUPO = IPCHP(J)
  168. C on établi la correspondance de composantes du
  169. C liste mots vers les nom de composantes de la sous zone
  170. NC = NOHARM(/1)
  171. NC1 = 0
  172. DO 600 K=1,NCOMP1
  173. ICOR1(K)=0
  174. DO 500 L=1,NC
  175. C write(6,*) MOTS(K),NOCOMP(L)
  176. IF(MOTS(K).EQ.NOCOMP(L)) THEN
  177. C write(6,*) 'chp1 sz',j,'ccomp',l,'lcomp',k
  178. ICOR1(K)=L
  179. C nbre de composante présente sur la sous zone
  180. NC1 = NC1 + 1
  181. ICOR2(NC1)=K
  182. GOTO 600
  183. ENDIF
  184. 500 CONTINUE
  185. 600 CONTINUE
  186.  
  187. C on remplit chaque point du meleme
  188. MELEME = IGEOC
  189. MPOVAL = IPOVAL
  190. SEGACT MELEME,MPOVAL
  191. C boucle sur les composantes
  192. DO 800 K=1,NC1
  193. KK = ICOR2(K)
  194. LC = ICOR1(KK)
  195. C numero local de l'harmonique
  196. IHA = IHARNU(NOHARM(LC)-NMIN+1)
  197. C boucle sur les points
  198. DO 700 L=1,NUM(/2)
  199. NBP = NUM(1,L)
  200. C remplissage ici
  201. VALCPR(NBP,KK,IHA)
  202. & =VPOCHA(L,LC)
  203. 700 CONTINUE
  204. 800 CONTINUE
  205. SEGDES MELEME,MPOVAL,MSOUPO
  206. 900 CONTINUE
  207. C
  208. C on passe au second champ point
  209. MCHPOI = ICHP(2)
  210. MLMOTS = ILMO(2)
  211. DO 1400 J=1,IPCHP(/1)
  212. MSOUPO = IPCHP(J)
  213. SEGACT MSOUPO
  214. C on établi la correspondance de composantes du
  215. C liste mots vers les nom de composantes de la sous zone
  216. NC = NOHARM(/1)
  217. NC1 = 0
  218. C
  219. ncomp1 = mots(/2)
  220. C
  221. DO 1100 K=1,NCOMP1
  222. ICOR1(K)=0
  223. DO 1000 L=1,NC
  224. C write(6,*) 'mots=',MOTS(K),'Comp=',NOCOMP(L)
  225. IF(MOTS(K).EQ.NOCOMP(L)) THEN
  226. C write(6,*) 'chp2 sz',j,'ccomp',l,'lcomp',k
  227. ICOR1(K)=L
  228. C nbre de composante présente sur la sous zone
  229. NC1 = NC1 + 1
  230. ICOR2(NC1)=K
  231. GOTO 1100
  232. ENDIF
  233. 1000 CONTINUE
  234. 1100 CONTINUE
  235.  
  236. C on remplit chaque point du meleme
  237. MELEME = IGEOC
  238. MPOVAL = IPOVAL
  239. SEGACT MELEME,MPOVAL
  240. C boucle sur les composantes
  241. DO 1300 K=1,NC1
  242. KK = ICOR2(K)
  243. LC = ICOR1(KK)
  244. C numero local de l'harmonique
  245. IHA = IHARNU(NOHARM(LC)-NMIN+1)
  246. C boucle sur les points
  247. DO 1200 L=1,NUM(/2)
  248. NBP = NUM(1,L)
  249. C multiplication ou division ici
  250. IF (IEPS.EQ.1) THEN
  251. VALCPR(NBP,KK,IHA)
  252. & =VALCPR(NBP,KK,IHA)*VPOCHA(L,LC)
  253. ELSE
  254. IF (IVCHPO) THEN
  255. VALCPR(NBP,KK,IHA)
  256. & =VPOCHA(L,LC)/VALCPR(NBP,KK,IHA)
  257. ELSE
  258. VALCPR(NBP,KK,IHA)
  259. & =VALCPR(NBP,KK,IHA)/VPOCHA(L,LC)
  260. ENDIF
  261. ENDIF
  262. 1200 CONTINUE
  263. 1300 CONTINUE
  264. SEGDES MELEME,MPOVAL
  265. 1400 CONTINUE
  266. SEGSUP ICOR1,ICOR2
  267. C
  268. C
  269. C impression de icpr
  270. C WRITE(6,*) 'PTS',XCOOR(/1)/(IDIM+1),'COMP',ncomp1,'Nhar',nhar
  271. C do 6003 i=1,XCOOR(/1)/(IDIM+1)
  272. C write(6,5001) i
  273. C do 6002 j=1,ncomp1
  274. C do 6001 k=1,nhar
  275. C write(6,5002) j,k,valcpr(i,j,k)
  276. C 6001 continue
  277. C 6002 continue
  278. C 6003 continue
  279.  
  280. C 5001 format('Point numero',I4)
  281. C 5002 format('Composante',I2,'Harmonique',I2,'Valeur',G12.5)
  282.  
  283.  
  284. C
  285. C il faut maintenant creer le champ point résultat
  286. C on commence par
  287. MCHPOI=ICHP(2)
  288. MLMOTS=ILMO(2)
  289. C
  290. C muchp2 determine le nombre de sous zone de notre chpoint
  291. C
  292. C write(6,*) 'Appel à muchp2'
  293. CALL MUCHP2(MCHPOI,MLMOTS,MCORES,JCHACO,KCHACO,IHARNU,NMIN)
  294. C en sortie de mcuchp2 les segment sont actifs
  295. C
  296. C création du nouveau champ par point
  297. C
  298. C nini = jchaco(/2)
  299. C write(6,*)'tableau jchaco 1: kcomp 2:khar 3:nbre pts 4:nb comp'
  300. C do 6005 i=1,nini
  301. C write(6,5003) jchaco(1,i),jchaco(2,i),jchaco(3,i),jchaco(4,i)
  302. C 6005 continue
  303. C 5003 format(' ',4(I5,2X))
  304. C
  305. C nini = kchaco(/1)
  306. C write(6,*)'tableau kchaco correspondace 1 -> 3'
  307. C write(6,5004) (kchaco(i),i=1,nini)
  308. C 5004 format(' ',6(I2,2X))
  309. C
  310. C write(6,*) 'Tableau mcores - icor3'
  311. C nono = icor3(/1)
  312. C write(6,*) 'icor3(/1)=' ,nono
  313. C do 6004 i=1,nini
  314. C write(6,*) 'sous zone' , i
  315. C write(6,5005) (icor3(j,i),j=1,nono)
  316. C 6004 continue
  317. C 5005 format(10(I2,2X))
  318. C
  319. C attention inversion volontaire
  320. MCHPO1 = ICHP(2)
  321. MCHPO2 = ICHP(1)
  322. NSOUPO = JCHACO(/2)
  323. NAT = 1
  324. SEGINI MCHPO3
  325. NSOUP1 = NSOUPO
  326. NSOUPO= MCHPO1.IPCHP(/1)
  327. MCHPO3.MOCHDE = 'PRODUIT DE DEUX CHAMP POINT PAR *'
  328. MCHPO3.MTYPOI = ' '
  329.  
  330. C nature du champoint
  331. CALL LIRMOT(MONATU,1,IVAL,0)
  332. IF ( IVAL .EQ.1 ) THEN
  333. CALL LIRMOT(MOTCLE,3,IVAL,1)
  334. IF ( IERR .NE. 0) RETURN
  335. MCHPO3.JATTRI(1) = IVAL-1
  336. ELSE
  337. NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1)
  338. IF ( NATRI .EQ. 0) THEN
  339. MCHPO3.JATTRI(1) = 0
  340. ELSE IF ( NATRI .EQ. 1) THEN
  341. MCHPO3.JATTRI(1) = 1
  342. ELSE IF ( NATRI .EQ. 2) THEN
  343. C la nature discrete domine
  344. MCHPO3.JATTRI(1) = 2
  345. ELSE
  346. MCHPO3.JATTRI(1) = 2
  347. ENDIF
  348. ENDIF
  349. MCHPO3.IFOPOI = IFOUR
  350. C
  351. C boucle sur les sous zones DE MCHPO3
  352. C
  353. DO 2200 I=1,NSOUP1
  354. NC = JCHACO(4,I)
  355. NBELEM=JCHACO(3,I)
  356. C cas ou la sous zone n'existe pas encore
  357. SEGINI MSOUP3
  358. MCHPO3.IPCHP(I)=MSOUP3
  359. NBNN = 1
  360. C on cherche la première sous zone correspondante
  361. DO 1500 J=I,NSOUPO
  362. IF (KCHACO(J).EQ.I) GOTO 1600
  363. 1500 CONTINUE
  364. C ici j est le numéro de la premièer sous zone de mchpo1 correspondante
  365. 1600 CONTINUE
  366. MSOUP1 = MCHPO1.IPCHP(J)
  367. SEGACT MSOUP1
  368. IPT1 = MSOUP1.IGEOC
  369. SEGACT IPT1
  370. IF (NBELEM.EQ.IPT1.NUM(/2)) THEN
  371. IPT3 = IPT1
  372. ELSE
  373. NBSOUS = 0
  374. NBREF = 0
  375. NBNN = 1
  376. SEGINI IPT3
  377. DO 1650 K=1,IPT1.NUM(/2)
  378. IPT3.NUM(1,K)=IPT1.NUM(1,K)
  379. 1650 CONTINUE
  380. ENDIF
  381. MSOUP3.IGEOC = IPT3
  382. NR3 = IPT1.NUM(/2)
  383. N = NBELEM
  384. SEGINI MPOVA3
  385. MSOUP3.IPOVAL= MPOVA3
  386. C
  387. C nom des composantes et harmoniques
  388. C
  389. IC = 0
  390. DO 1800 K=1,NCOMP1
  391. IF (ICOR3(K,J).NE.0) THEN
  392. IC = IC + 1
  393. MSOUP3.NOCOMP(IC) = MLMOT3.MOTS(K)
  394. MSOUP3.NOHARM(IC) = MSOUP1.NOHARM(ICOR3(K,J))
  395. MSOUP3.NOCONS(IC) = MSOUP1.NOCONS(ICOR3(K,J))
  396. C
  397. C 1 ier remplissage
  398. C
  399. DO 1700 L=1,IPT1.NUM(/2)
  400. NBP = IPT1.NUM(1,L)
  401. MPOVA3.VPOCHA(L,IC)=
  402. & VALCPR(NBP,K,IHARNU(MSOUP3.NOHARM(IC)-NMIN+1))
  403. 1700 CONTINUE
  404. ENDIF
  405. 1800 CONTINUE
  406. SEGDES MSOUP1,IPT1
  407. C
  408. C remplissage suivant
  409. C
  410. C write(6,*) 'nr3=',nr3,'nbelem=',nbelem
  411. IF (NR3 .NE. NBELEM) THEN
  412. C write(6,*) 'Compactage de la sous zone'
  413. C on cherche la prochaine sous zone correspondante
  414. DO 2100 K=J+1,NSOUPO
  415. IF (KCHACO(K).EQ.I) THEN
  416. C k est le numéro de la sous zone de mchpo1
  417. MSOUP1 = MCHPO1.IPCHP(K)
  418. SEGACT MSOUP1
  419. IPT1 = MSOUP1.IGEOC
  420. SEGACT IPT1
  421. IC = 0
  422. DO 2000 L=1,NCOMP1
  423. IF (ICOR3(L,K).NE.0) THEN
  424. IC = IC + 1
  425. DO 1900 M=1,IPT1.NUM(/2)
  426. NBP = IPT1.NUM(1,M)
  427. IPT3.NUM(1,NR3+M) = NBP
  428. MPOVA3.VPOCHA(NR3+M,IC)=
  429. & VALCPR(NBP,L,IHARNU(MSOUP3.NOHARM(IC)-NMIN+1))
  430. 1900 CONTINUE
  431.  
  432. ENDIF
  433. 2000 CONTINUE
  434. NR3 = NR3 + IPT1.NUM(/2)
  435. SEGDES MSOUP1,IPT1
  436. ENDIF
  437. 2100 CONTINUE
  438. IF ( NR3.NE.NBELEM.OR.NC.NE.IC)THEN
  439. C write(6,*)'nr3',nr3,'nbelem',nbelem,'nc',nc,'ic',ic
  440. WRITE(IOIMP,*) 'erreur dans muchpo1.eso'
  441. CALL ERREUR(5)
  442. RETURN
  443. ENDIF
  444. C on ferme la sous zone du nouveau chpoint
  445.  
  446. ENDIF
  447. SEGDES IPT3,MPOVA3,MSOUP3
  448. 2200 CONTINUE
  449. SEGDES MCHPO2,MCHPO1,MCHPO3
  450. C on détruit les temporaires
  451. SEGSUP ICPR,IHARNU,NUMHAR,JCHACO,KCHACO,MCORES
  452. SEGDES ,MLMOT1,MLMOT2,MLMOT3
  453. IRET = MCHPO3
  454. RETURN
  455. END
  456.  
  457.  
  458.  
  459.  
  460.  
  461.  
  462.  
  463.  

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