1 : C MUPOSC SOURCE GOUNAND 11/10/07 21:16:00 7151 2 : SUBROUTINE MUPOSC(IPOI1,IPOI2,IEPS,IRET) 3 : C======================================================================= 4 : C 5 : C ENTREE 6 : C IPOI1=CHPOINT 7 : C IPOI2=CHPOINT 8 : C IEPS =1 MULTIPLICATION -1 DIVISION 9 : C SORTIES 10 : C IRET =POINTEUR SUR CHPOINT RESULTANT 11 : C =0 SINON (UN MESSAGE D ERREUR EST ALORS IMPRIME ) 12 : C 13 : C REGLE DE MULTIPLICATION : TOUT POINT AYANT DANS UN CHPOINT UNE 14 : C COMPOSANTE UNIQUE DE NOM "SCAL" VOIT TOUTES LES VALEURS DES 15 : C COMPOSANTES DE L'AUTRE CHPOINT MULTIPLIER PAR LA VALEUR SCALAIRE. 16 : C 17 : C LE CHPOINT RESULTAT NE COMPORTE QUE LES POINTS CITES CI-DESSUS. 18 : C 19 : C======================================================================= 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8(A-H,O-Z) 22 : -INC SMCHPOI 23 : -INC SMCOORD 24 : -INC CCOPTIO 25 : -INC SMELEME 26 : -INC TMTRAV 27 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 28 : SEGMENT ICOR(XCOOR(/1)/(IDIM+1)) 29 : SEGMENT ICOM(0) 30 : SEGMENT SCOM 31 : CHARACTER*4 COM(0) 32 : ENDSEGMENT 33 : SEGMENT NOHA(0) 34 : IRET=0 35 : MCHPO1=IPOI1 36 : MCHPO2=IPOI2 37 : MCHPOI=MCHPO1 38 : IPASS=0 39 : IA=0 40 : SEGINI ICPR ,SCOM ,NOHA 41 : C 42 : C ON FABRIQUE MTRAV A LA DIMENSION MAX POUR CELA FABRICATION DE 43 : C ICPR QUI DONNE NNNOE PUIS DE ICOM QUI SERA NNIN 44 : 1000 CONTINUE 45 : SEGACT MCHPOI 46 : NSOUP =IPCHP(/1) 47 : DO 1 I = 1,NSOUP 48 : MSOUPO=IPCHP(I) 49 : SEGACT MSOUPO 50 : IF(I.EQ.1.AND.IPASS.EQ.0) THEN 51 : COM(**)=NOCOMP(1) 52 : NOHA(**)=NOHARM(1) 53 : ENDIF 54 : DO 2 J=1,NOCOMP(/2) 55 : NNIN=COM(/2) 56 : DO 3 K=1,NNIN 57 : IF(NOCOMP(J).EQ.COM(K)) GO TO 2 58 : 3 CONTINUE 59 : COM(**)=NOCOMP(J) 60 : NOHA(**)=NOHARM(J) 61 : 2 CONTINUE 62 : MELEME=IGEOC 63 : SEGACT MELEME 64 : DO 4 J=1,NUM(/2) 65 : IF(ICPR(NUM(1,J)).NE.0) GO TO 4 66 : IA=IA+1 67 : ICPR(NUM(1,J))=IA 68 : 4 CONTINUE 69 : SEGDES MELEME,MSOUPO 70 : 1 CONTINUE 71 : IF(IIMPI.NE.0) WRITE(IOIMP,100) IA 72 : 100 FORMAT(' NOMBRE DE NOEUDS CONCERNES PAR LES 2 CHPOINTS',I5) 73 : SEGDES MCHPOI 74 : IF(IPASS.EQ.0) THEN 75 : IPASS=1 76 : MCHPOI=MCHPO2 77 : GO TO 1000 78 : ENDIF 79 : NNNOE=IA 80 : NNIN=COM(/2) 81 : SEGINI MTRAV 82 : C 83 : C ON REMPLIT INCO ET IGEO 84 : C 85 : DO 5 I=1,NNIN 86 : NHAR(I)=NOHA(I) 87 : INCO(I)=COM(I) 88 : 5 CONTINUE 89 : SEGSUP SCOM,NOHA 90 : MCHPOI=MCHPO1 91 : IPASS=0 92 : 1001 CONTINUE 93 : SEGACT MCHPOI 94 : NSOUP = IPCHP(/1) 95 : DO 6 I=1,NSOUP 96 : MSOUPO=IPCHP(I) 97 : SEGACT MSOUPO 98 : MELEME=IGEOC 99 : SEGACT MELEME 100 : DO 7 J = 1,NUM(/2) 101 : IA=ICPR(NUM(1,J)) 102 : IGEO(IA)=NUM(1,J) 103 : 7 CONTINUE 104 : SEGDES MELEME,MSOUPO 105 : 6 CONTINUE 106 : SEGDES MCHPOI 107 : IF(IPASS.EQ.0) THEN 108 : IPASS=1 109 : MCHPOI=MCHPO2 110 : GO TO 1001 111 : ENDIF 112 : C 113 : C ON EFFECTUE LE TRAVAIL. ON ISOLE D'ABORD LA PARTIE CONCERNANT 114 : C UNIQUEMENT UNE COMPOSANTE DE NOM "SCAL". 115 : C 116 : MCHPOI=MCHPO1 117 : MCHPO3=MCHPO2 118 : IPASS=0 119 : 1003 CONTINUE 120 : SEGACT MCHPO3 121 : DO 10 I=1,MCHPO3.IPCHP(/1) 122 : MSOUP3=MCHPO3.IPCHP(I) 123 : SEGACT MSOUP3 124 : IF(MSOUP3.NOCOMP(/2).NE.1.OR.MSOUP3.NOCOMP(1).NE.'SCAL') THEN 125 : SEGDES MSOUP3 126 : GO TO 10 127 : ENDIF 128 : C ON FABRIQUE UNE CORRESPONDANCE ICOR(I)=J VEUT DIRE QUE LE NOEUD I EST 129 : C EN J EME POSITION DANS CE MELEME 130 : C 131 : SEGINI ICOR 132 : IPT3=MSOUP3.IGEOC 133 : SEGACT IPT3 134 : DO 11 J=1,IPT3.NUM(/2) 135 : ICOR(IPT3.NUM(1,J))=J 136 : 11 CONTINUE 137 : MPOVA3=MSOUP3.IPOVAL 138 : SEGDES MSOUP3,IPT3 139 : SEGACT MPOVA3 140 : SEGACT MCHPOI 141 : DO 12 J=1,IPCHP(/1) 142 : MSOUPO=IPCHP(J) 143 : SEGACT MSOUPO 144 : IF(IPASS.NE.0) THEN 145 : C TEST POUR NE PAS REFAIRE LA MULTIPLICATION SCAL PAR SCAL 146 : IF(NOCOMP(/2).EQ.1.AND.NOCOMP(1).EQ.'SCAL') THEN 147 : SEGDES MSOUPO 148 : GO TO 12 149 : ENDIF 150 : ENDIF 151 : SEGINI ICOM 152 : DO 13 K=1,NOCOMP(/2) 153 : DO 13 L=1,NNIN 154 : IF(NOCOMP(K).EQ.INCO(L)) ICOM(**) = L 155 : 13 CONTINUE 156 : MELEME=IGEOC 157 : MPOVAL=IPOVAL 158 : SEGACT MELEME,MPOVAL 159 : DO 14 K=1,NUM(/2) 160 : IC=ICOR(NUM(1,K)) 161 : IF(IC.EQ.0) GO TO 14 162 : IB=ICPR(NUM(1,K)) 163 : DO 15 L=1,NOCOMP(/2) 164 : IE=ICOM(L) 165 : IBIN(IE,IB)=1 166 : IF(IEPS.EQ.1)BB(IE,IB)=BB(IE,IB)+MPOVA3.VPOCHA(IC,1)*VPOCHA(K,L) 167 : IF(IEPS.EQ.-1)BB(IE,IB)=BB(IE,IB)+VPOCHA(K,L)/MPOVA3.VPOCHA(IC,1) 168 : 15 CONTINUE 169 : 14 CONTINUE 170 : SEGDES MELEME,MPOVAL,MSOUPO 171 : SEGSUP ICOM 172 : 12 CONTINUE 173 : SEGDES MPOVA3,MCHPOI 174 : SEGSUP ICOR 175 : 10 CONTINUE 176 : SEGDES MCHPO3 177 : IF(IPASS.EQ.0) THEN 178 : MCHPOI=MCHPO2 179 : MCHPO3=MCHPO1 180 : IPASS=1 181 : GO TO 1003 182 : ENDIF 183 : KTRAV=MTRAV 184 : *SG Emettre une erreur ne semble pas forcément utile 185 : *SG On laisse la création d'un chpoint vide par CRECHP 186 : C DO 50 I=1,NNIN 187 : C DO 50 J=1,NNNOE 188 : C IF(IBIN(I,J).NE.0) GO TO 60 189 : C 50 CONTINUE 189 : C CALL ERREUR(179) 190 : C SEGSUP MTRAV,ICPR 191 : C RETURN 192 : C 60 CONTINUE 192 : CALL CRECHP(KTRAV,IRET) 193 : MTRAV=KTRAV 194 : SEGSUP MTRAV,ICPR 195 : RETURN 196 : END 197 : 198 : 199 : 200 :
© Cast3M 2003 - All rights reserved.
Disclaimer