1 : C PROSCA SOURCE CHAT 05/01/13 02:34:56 5004 2 : SUBROUTINE PROSCA(MCHPO1,MCHPO2,MLMOTX,MLMOTY,IRET) 3 : C----------------------------------------------------------------------- 4 : C PRODUIT SCALAIRE DE 2 CHPOINTS 5 : C----------------------------------------------------------------------- 6 : C EN STANDARD LE CHPOINT RESULTAT A POUR NUMERO D'HARMONIQUE 0 7 : C EN SERIE DE FOURIER , IL EST TYPE NOHARM 8 : C----------------------------------------------------------------------- 9 : C ENTREE 10 : C IPOI1 CHPOINT 11 : C IPOI2 CHPOINT 12 : C MLMOTX LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER CHPOINT 13 : C MLMOTY LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHPOINT 14 : C SORTIE 15 : C IRET POINTEUR SUR LE CHPOINT RESULTAT 16 : C----------------------------------------------------------------------- 17 : IMPLICIT INTEGER(I-N) 18 : IMPLICIT REAL*8(A-H,O-Z) 19 : -INC CCOPTIO 20 : -INC SMCHPOI 21 : -INC SMLMOTS 22 : -INC SMELEME 23 : -INC SMCOORD 24 : -INC TMTRAV 25 : CHARACTER*4 NOIN,NOMIL 26 : SEGMENT ITRAV 27 : REAL*8 IVAA(NINC,NPOI),IVAB(NINC,NPOI) 28 : INTEGER IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI) 29 : CHARACTER*4 INCA(NINC),INCB(NINC) 30 : ENDSEGMENT 31 : DATA NOMIL/'NOHA'/ 32 : NPOI=XCOOR(/1)/(IDIM+1) 33 : MLMOTS=MLMOTX 34 : SEGACT MLMOTS 35 : NINC= MOTS(/2) 36 : SEGINI ITRAV 37 : DO 1 I = 1, NINC 38 : INCA(I)=MOTS(I) 39 : 1 CONTINUE 40 : SEGDES MLMOTS 41 : MLMOTS=MLMOTY 42 : SEGACT MLMOTS 43 : IF(MOTS(/2).NE.NINC) THEN 44 : SEGDES MLMOTS 45 : SEGSUP ITRAV 46 : MOTERR(1:4)='PSCA' 47 : MOTERR(5:12)='LISTMOTS' 47 : CALL ERREUR(125) 48 : RETURN 49 : ENDIF 50 : DO 21 I = 1, NINC 51 : INCB(I)=MOTS(I) 52 : 21 CONTINUE 53 : SEGDES MLMOTS 54 : C 55 : C ********* IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB 56 : C ********* CREATION D'ABORD DE IVAA PUIS DE IVAB 57 : C 58 : MCHPOI=MCHPO1 59 : SEGACT MCHPOI 60 : NSOUPO = IPCHP(/1) 61 : DO 2 M = 1,NSOUPO 62 : MSOUPO = IPCHP(M) 63 : SEGACT MSOUPO 64 : NC=NOCOMP(/2) 65 : DO 10 I = 1,NINC 66 : 10 IPOS(I)=0 67 : DO 4 K = 1, NINC 68 : DO 3 J = 1, NC 69 : NOIN= NOCOMP (J) 70 : IF(INCA(K). EQ . NOIN) THEN 71 : IPOS(K)=J 72 : GO TO 4 73 : ENDIF 74 : 3 CONTINUE 75 : 4 CONTINUE 76 : DO 5 I = 1,NINC 77 : IF(IPOS(I). NE . 0) GO TO 6 78 : 5 CONTINUE 79 : GO TO 8 80 : 6 CONTINUE 81 : MELEME=IGEOC 82 : SEGACT MELEME 83 : NBELEM=NUM(/2) 84 : MPOVAL=IPOVAL 85 : SEGACT MPOVAL 86 : DO 9 LI = 1,NINC 87 : KL = IPOS(LI) 88 : IF(KL.EQ.0) GO TO 9 89 : DO 7 I = 1,NBELEM 90 : I1 = NUM(1,I) 91 : IVAA(LI,I1)=VPOCHA(I,KL) 92 : ICPRA(I1)=1 93 : 7 CONTINUE 94 : 9 CONTINUE 95 : SEGDES MELEME,MPOVAL 96 : 8 CONTINUE 97 : SEGDES MSOUPO 98 : 2 CONTINUE 99 : SEGDES MCHPOI 100 : C 101 : C TRAITEMENT DU 2-EME CHPOINT 102 : C 103 : IA=0 104 : MCHPOI=MCHPO2 105 : SEGACT MCHPOI 106 : NSOUPO = IPCHP(/1) 107 : DO 12 M = 1,NSOUPO 108 : MSOUPO = IPCHP(M) 109 : SEGACT MSOUPO 110 : NC=NOCOMP(/2) 111 : DO 11 I = 1,NINC 112 : 11 IPOS(I)=0 113 : DO 14 K= 1,NINC 114 : DO 13 J = 1, NC 115 : NOIN= NOCOMP (J) 116 : IF(INCB(K). EQ . NOIN) THEN 117 : IPOS(K)=J 118 : GO TO 14 119 : ENDIF 120 : 13 CONTINUE 121 : 14 CONTINUE 122 : DO 15 I = 1,NINC 123 : IF(IPOS(I). NE . 0) GO TO 16 124 : 15 CONTINUE 125 : GO TO 18 126 : 16 CONTINUE 127 : MELEME=IGEOC 128 : SEGACT MELEME 129 : NBELEM=NUM(/2) 130 : MPOVAL=IPOVAL 131 : SEGACT MPOVAL 132 : DO 19 LI = 1,NINC 133 : KL = IPOS(LI) 134 : IF(KL.EQ.0) GO TO 19 135 : DO 17 I = 1,NBELEM 136 : I1 = NUM(1,I) 137 : IVAB(LI,I1)=VPOCHA(I,KL) 138 : IF(ICPRA(I1).NE.0) THEN 139 : IA=IA+1 140 : ICPRB(I1)=IA 141 : ENDIF 142 : 17 CONTINUE 143 : 19 CONTINUE 144 : SEGDES MELEME,MPOVAL 145 : 18 CONTINUE 146 : SEGDES MSOUPO 147 : 12 CONTINUE 148 : IF(IA.EQ.0) THEN 149 : C 150 : C CHPOINT VIDE 151 : C 152 : SEGSUP ITRAV 153 : SEGDES MCHPOI 154 : NSOUPO=0 155 : NAT=1 156 : SEGINI MCHPOI 157 : IFOPOI=IFOUR 158 : SEGDES MCHPOI 159 : IRET=MCHPOI 160 : RETURN 161 : ENDIF 162 : C 163 : C ON EFFECTUE LE CALCUL 164 : C 165 : NNIN=1 166 : NNNOE=IA 167 : SEGINI MTRAV 168 : INCO(1)='SCAL' 169 : * 170 : * MODIF MILL LE 18 / 7 / 90 171 : * REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON 172 : * 173 : READ(NOMIL,FMT='(A4)') NHMIL 174 : IF(IFOPOI.EQ.1) THEN 175 : NHAR(1)=NHMIL 176 : ELSE 177 : NHAR(1)=0 178 : ENDIF 179 : * 180 : MCHPOI=MCHPO1 181 : SEGACT MCHPOI 182 : NSOUPO=IPCHP(/1) 183 : DO 22 M=1,NSOUPO 184 : MSOUPO=IPCHP(M) 185 : SEGACT MSOUPO 186 : MELEME=IGEOC 187 : SEGACT MELEME 188 : DO 27 J=1,NUM(/2) 189 : I1=NUM(1,J) 190 : IB=ICPRB(I1) 191 : IF(IB.EQ.0) GO TO 27 192 : IF(IGEO(IB).NE.0) GO TO 27 193 : IGEO(IB)=I1 194 : IBIN(1,IB)=1 195 : DO 28 LI=1,NINC 196 : 28 BB(1,IB)=BB(1,IB)+IVAA(LI,I1)*IVAB(LI,I1) 197 : 27 CONTINUE 198 : SEGDES MELEME,MSOUPO 199 : 22 CONTINUE 200 : SEGDES MCHPOI 201 : SEGSUP ITRAV 201 : CALL CRECHP(MTRAV,IRET) 202 : SEGSUP MTRAV 203 : RETURN 204 : END 205 : 206 :
© Cast3M 2003 - All rights reserved.
Disclaimer