Télécharger la plaquette Cast3M


fr en

Télécharger muchp1.eso

Retour à la liste

Numérotation des lignes : 

muchp1

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

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