C MUCHP1 SOURCE GOUNAND 11/06/29 21:15:13 7016 SUBROUTINE MUCHP1(IPOI1,IPOI2,LMOT1,LMOT2,LMOT3,IEPS,IRET) c======================================================================= c c entree c ipoi1=chpoint c ipoi2=chpoint c lmot1=liste de mots1 c lmot2=liste de mots2 c lmot3=liste de mots3 c sorties c iret = pointeur sur chpoint resultant c = 0 sinon (un message d erreur est alors imprime ) c c c======================================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMCHPOI -INC CCOPTIO -INC SMELEME -INC SMLMOTS -INC SMCOORD * le tableau icpr contient la mise en ordre des 3 chpoint SEGMENT ICPR * nbre harm. comp points chpoints REAL*8 VALCPR(XCOOR(/1)/(IDIM+1),NCOMP1,NHAR) ENDSEGMENT * nocmp1 et le nombre de composante dans chaque listmot * nhar est le nombre d'harmonique de Fourrier présent * ce segment contient les numéro des différents harmoniques trouvées * et l'inversion du tableau SEGMENT NUMHAR(NHAR) SEGMENT IHARNUM(NVHAR) * ce tableau sert de correspondance entre les composantes des liste mot * et celles des champ point pour chaque sous zone SEGMENT ICOR1(NCOMP1) SEGMENT ICOR2(NCOMP1) * * ces segment servent au moment de l'assemblage du nouveau chpoint * celui stocke le nombre de sous zone du nouveau chpoint SEGMENT JCHACO(4,NSOUP1) * indice 1 et 2 voir muchpo2 , 3 nombre de pts , 4 nbre de composante * kchaco donne l'adresse dans jchaco de la sous zone SEGMENT KCHACO(NSOUPO) SEGMENT MCORES * correspondence comp listmot comp sous zone INTEGER ICOR3(NCOMP1,NSOUPO) * indice 1 contient sum 2**i si i présent * indice 2 contient le nombre de i present INTEGER KCOMP(2,NSOUPO) INTEGER KHARM(NSOUPO) ENDSEGMENT * * ce tableau contient les pointeurs des deux champ point et des listemots DIMENSION ICHP(2),ILMO(2),NR(2) CHARACTER*4 MOTCLE(3),MONATU(1) DATA MOTCLE/'INDE','DIFF','DISC'/ DATA MONATU/'NATU'/ LOGICAL IVCHPO * * executable * verification de la dimension des listmots MLMOT1=LMOT1 MLMOT2=LMOT2 MLMOT3=LMOT3 SEGACT MLMOT1,MLMOT2,MLMOT3 NCOMP1 = MLMOT1.MOTS(/2) NCOMP2 = MLMOT2.MOTS(/2) NCOMP3 = MLMOT3.MOTS(/2) IF (NCOMP1.NE.NCOMP2.OR.NCOMP3.NE.NCOMP1) THEN * erreur dans la dimension des lismots CALL ERREUR(854) SEGDES MLMOT1,MLMOT2,MLMOT3 RETURN ENDIF * determination du nombre d'harmonique de Fourrier * expédition rapide du cas sans harmonique NR(1) = 0 NR(2) = 0 ILMO(1)=LMOT1 ILMO(2)=LMOT2 ICHP(1)= IPOI1 ICHP(2)= IPOI2 * MCHPO1 = IPOI1 MCHPO2 = IPOI2 SEGACT MCHPO1,MCHPO2 NHAR = 1 NSUM = 0 * boucle sur les 2 champoints DO 300 K=1,2 MCHPO1 = ICHP(K) DO 200 I=1,MCHPO1.IPCHP(/1) MSOUPO = MCHPO1.IPCHP(I) SEGACT MSOUPO MELEME = IGEOC SEGACT MELEME NR(K) = NR(K) + NUM(/2) SEGDES MELEME DO 100 J=1,NOHARM(/1) NSUM = NSUM + NOHARM(J) 100 CONTINUE 200 CONTINUE 300 CONTINUE * * combien y a t'il d'harmoniques ? * IF (NSUM .NE. 0) THEN * il y en a plusieurs * write(6,*) 'Appel de noharm' CALL NHARMO(IPOI1,IPOI2,NHAR,NUMHAR,NMIN,IHARNUM) NVHAR=IHARNUM(/1) ELSE * cas simple toutes les harmoniques sont nulles NHAR = 1 NVHAR= 1 SEGINI NUMHAR,IHARNUM NUMHAR(1)=0 IHARNUM(1)=1 NMIN=0 ENDIF * * write(6,*) 'points',XCOOR(/1)/(IDIM+1),'Comp',ncomp1,'nhar',nhar * * initialisation du tableau SEGINI ICPR * ordre des opérations * cela va dépendre des remplissage respectifs NR1 et NR2 * NRR1=MAX(NR(1),NR(2)) NRR2=MIN(NR(1),NR(2)) DNRR1 = REAL(NRR1) DNRR2 = REAL(NRR2) TAUX = DNRR2 / (DNRR1+0.1) * write(6,*) 'Taux de remplissage',taux * on classe les champ point dans l'ordre de taille IF ((NRR1.NE.NR(1).AND.TAUX.LT.0.5).OR. & (NRR1.EQ.NR(1).AND.TAUX.GE.0.5)) THEN * write(6,*) 'Inversion de l ordre des champoints' * write(6,*) 'Taux de remplissage' ,taux IDUM1 = ICHP(1) IDUM2 = ILMO(1) ICHP(1)=ICHP(2) ILMO(1)=ILMO(2) ICHP(2)=IDUM1 ILMO(2)=IDUM2 IVCHPO=.TRUE. ELSE IVCHPO=.FALSE. ENDIF * remplissage du tableau en bouclant sur les champ par points * on boucle sur les deux champ point * pour chaque sous zone on établi la correspondance de composantes du * liste mots vers les nom de composantes de la sous zone SEGINI ICOR1,ICOR2 * pseudo boucle sur les champ points MCHPOI = ICHP(1) MLMOTS = ILMO(1) DO 900 J=1,IPCHP(/1) MSOUPO = IPCHP(J) * on établi la correspondance de composantes du * liste mots vers les nom de composantes de la sous zone NC = NOHARM(/1) NC1 = 0 DO 600 K=1,NCOMP1 ICOR1(K)=0 DO 500 L=1,NC * write(6,*) MOTS(K),NOCOMP(L) IF(MOTS(K).EQ.NOCOMP(L)) THEN * write(6,*) 'chp1 sz',j,'ccomp',l,'lcomp',k ICOR1(K)=L * nbre de composante présente sur la sous zone NC1 = NC1 + 1 ICOR2(NC1)=K GOTO 600 ENDIF 500 CONTINUE 600 CONTINUE * on remplit chaque point du meleme MELEME = IGEOC MPOVAL = IPOVAL SEGACT MELEME,MPOVAL * boucle sur les composantes DO 800 K=1,NC1 KK = ICOR2(K) LC = ICOR1(KK) * numero local de l'harmonique IHA = IHARNUM(NOHARM(LC)-NMIN+1) * boucle sur les points DO 700 L=1,NUM(/2) NBP = NUM(1,L) * remplissage ici VALCPR(NBP,KK,IHA) & =VPOCHA(L,LC) 700 CONTINUE 800 CONTINUE SEGDES MELEME,MPOVAL,MSOUPO 900 CONTINUE * * on passe au second champ point MCHPOI = ICHP(2) MLMOTS = ILMO(2) DO 1400 J=1,IPCHP(/1) MSOUPO = IPCHP(J) SEGACT MSOUPO * on établi la correspondance de composantes du * liste mots vers les nom de composantes de la sous zone NC = NOHARM(/1) NC1 = 0 * ncomp1 = mots(/2) * DO 1100 K=1,NCOMP1 ICOR1(K)=0 DO 1000 L=1,NC * write(6,*) 'mots=',MOTS(K),'Comp=',NOCOMP(L) IF(MOTS(K).EQ.NOCOMP(L)) THEN * write(6,*) 'chp2 sz',j,'ccomp',l,'lcomp',k ICOR1(K)=L * nbre de composante présente sur la sous zone NC1 = NC1 + 1 ICOR2(NC1)=K GOTO 1100 ENDIF 1000 CONTINUE 1100 CONTINUE * on remplit chaque point du meleme MELEME = IGEOC MPOVAL = IPOVAL SEGACT MELEME,MPOVAL * boucle sur les composantes DO 1300 K=1,NC1 KK = ICOR2(K) LC = ICOR1(KK) * numero local de l'harmonique IHA = IHARNUM(NOHARM(LC)-NMIN+1) * boucle sur les points DO 1200 L=1,NUM(/2) NBP = NUM(1,L) * multiplication ou division ici IF (IEPS.EQ.1) THEN VALCPR(NBP,KK,IHA) & =VALCPR(NBP,KK,IHA)*VPOCHA(L,LC) ELSE IF (IVCHPO) THEN VALCPR(NBP,KK,IHA) & =VPOCHA(L,LC)/VALCPR(NBP,KK,IHA) ELSE VALCPR(NBP,KK,IHA) & =VALCPR(NBP,KK,IHA)/VPOCHA(L,LC) ENDIF ENDIF 1200 CONTINUE 1300 CONTINUE SEGDES MELEME,MPOVAL 1400 CONTINUE SEGSUP ICOR1,ICOR2 * * * impression de icpr * WRITE(6,*) 'PTS',XCOOR(/1)/(IDIM+1),'COMP',ncomp1,'Nhar',nhar * do 6003 i=1,XCOOR(/1)/(IDIM+1) * write(6,5001) i * do 6002 j=1,ncomp1 * do 6001 k=1,nhar * write(6,5002) j,k,valcpr(i,j,k) * 6001 continue * 6002 continue * 6003 continue * 5001 format('Point numero',I4) * 5002 format('Composante',I2,'Harmonique',I2,'Valeur',G12.5) * * il faut maintenant creer le champ point résultat * on commence par MCHPOI=ICHP(2) MLMOTS=ILMO(2) * * muchp2 determine le nombre de sous zone de notre chpoint * * write(6,*) 'Appel à muchp2' CALL MUCHP2(MCHPOI,MLMOTS,MCORES,JCHACO,KCHACO,IHARNUM,NMIN) * en sortie de mcuchp2 les segment sont actifs * * création du nouveau champ par point * * nini = jchaco(/2) * write(6,*)'tableau jchaco 1: kcomp 2:khar 3:nbre pts 4:nb comp' * do 6005 i=1,nini * write(6,5003) jchaco(1,i),jchaco(2,i),jchaco(3,i),jchaco(4,i) * 6005 continue * 5003 format(' ',4(I5,2X)) * * nini = kchaco(/1) * write(6,*)'tableau kchaco correspondace 1 -> 3' * write(6,5004) (kchaco(i),i=1,nini) * 5004 format(' ',6(I2,2X)) * * write(6,*) 'Tableau mcores - icor3' * nono = icor3(/1) * write(6,*) 'icor3(/1)=' ,nono * do 6004 i=1,nini * write(6,*) 'sous zone' , i * write(6,5005) (icor3(j,i),j=1,nono) * 6004 continue * 5005 format(10(I2,2X)) * * attentioninversion volontaire MCHPO1 = ICHP(2) MCHPO2 = ICHP(1) NSOUPO = JCHACO(/2) NAT = 1 SEGINI MCHPO3 NSOUP1 = NSOUPO NSOUPO= MCHPO1.IPCHP(/1) MCHPO3.MOCHDE = 'PRODUIT DE DEUX CHAMP POINT PAR *' MCHPO3.MTYPOI = ' ' * nature du champoint CALL LIRMOT(MONATU,1,IVAL,0) IF ( IVAL .EQ.1 ) THEN CALL LIRMOT(MOTCLE,3,IVAL,1) IF ( IERR .NE. 0) RETURN MCHPO3.JATTRI(1) = IVAL ELSE NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1) IF ( NATRI .EQ. 0) THEN MCHPO3.JATTRI(1) = 0 ELSE IF ( NATRI .EQ. 1) THEN MCHPO3.JATTRI(1) = 1 ELSE IF ( NATRI .EQ. 2) THEN * la nature discrete domine MCHPO3.JATTRI(1) = 2 ELSE MCHPO3.JATTRI(1) = 2 ENDIF ENDIF MCHPO3.IFOPOI = IFOUR * * boucle sur les sous zones DE MCHPO3 * DO 2200 I=1,NSOUP1 NC = JCHACO(4,I) NBELEM=JCHACO(3,I) * cas ou la sous zone n'existe pas encore SEGINI MSOUP3 MCHPO3.IPCHP(I)=MSOUP3 NBNN = 1 * on cherche la première sous zone correspondante DO 1500 J=I,NSOUPO IF (KCHACO(J).EQ.I) GOTO 1600 1500 CONTINUE * ici j est le numéro de la premièer sous zone de mchpo1 correspondante 1600 CONTINUE MSOUP1 = MCHPO1.IPCHP(J) SEGACT MSOUP1 IPT1 = MSOUP1.IGEOC SEGACT IPT1 IF (NBELEM.EQ.IPT1.NUM(/2)) THEN IPT3 = IPT1 ELSE NBSOUS = 0 NBREF = 0 NBNN = 1 SEGINI IPT3 DO 1650 K=1,IPT1.NUM(/2) IPT3.NUM(1,K)=IPT1.NUM(1,K) 1650 CONTINUE ENDIF MSOUP3.IGEOC = IPT3 NR3 = IPT1.NUM(/2) N = NBELEM SEGINI MPOVA3 MSOUP3.IPOVAL= MPOVA3 * * nom des composantes et harmoniques * IC = 0 DO 1800 K=1,NCOMP1 IF (ICOR3(K,J).NE.0) THEN IC = IC + 1 MSOUP3.NOCOMP(IC) = MLMOT3.MOTS(K) MSOUP3.NOHARM(IC) = MSOUP1.NOHARM(ICOR3(K,J)) MSOUP3.NOCONS(IC) = MSOUP1.NOCONS(ICOR3(K,J)) * * 1 ier remplissage * DO 1700 L=1,IPT1.NUM(/2) NBP = IPT1.NUM(1,L) MPOVA3.VPOCHA(L,IC)= & VALCPR(NBP,K,IHARNUM(MSOUP3.NOHARM(IC)-NMIN+1)) 1700 CONTINUE ENDIF 1800 CONTINUE SEGDES MSOUP1,IPT1 * * remplissage suivant * * write(6,*) 'nr3=',nr3,'nbelem=',nbelem IF (NR3 .NE. NBELEM) THEN * write(6,*) 'Compactage de la sous zone' * on cherche la prochaine sous zone correspondante DO 2100 K=J+1,NSOUPO IF (KCHACO(K).EQ.I) THEN * k est le numéro de la sous zone de mchpo1 MSOUP1 = MCHPO1.IPCHP(K) SEGACT MSOUP1 IPT1 = MSOUP1.IGEOC SEGACT IPT1 IC = 0 DO 2000 L=1,NCOMP1 IF (ICOR3(L,K).NE.0) THEN IC = IC + 1 DO 1900 M=1,IPT1.NUM(/2) NBP = IPT1.NUM(1,M) IPT3.NUM(1,NR3+M) = NBP MPOVA3.VPOCHA(NR3+M,IC)= & VALCPR(NBP,L,IHARNUM(MSOUP3.NOHARM(IC)-NMIN+1)) 1900 CONTINUE ENDIF 2000 CONTINUE NR3 = NR3 + IPT1.NUM(/2) SEGDES MSOUP1,IPT1 ENDIF 2100 CONTINUE IF ( NR3.NE.NBELEM.OR.NC.NE.IC)THEN * write(6,*)'nr3',nr3,'nbelem',nbelem,'nc',nc,'ic',ic WRITE(6,*) 'erreur dans muchpo1.eso' CALL ERREUR(5) ENDIF * on ferme la sous zone du nouveau chpoint ENDIF SEGDES IPT3,MPOVA3,MSOUP3 2200 CONTINUE SEGDES MCHPO2,MCHPO1,MCHPO3 * on détruit les temporaires SEGSUP ICPR,IHARNUM,NUMHAR,JCHACO,KCHACO,MCORES SEGDES ,MLMOT1,MLMOT2,MLMOT3 IRET = MCHPO3 RETURN END