Esope source files

   1 : C SCACHA    SOURCE    BP208322  09/09/25    21:15:37     6513           
   2 :       SUBROUTINE SCACHA(IPCHE1,IPCHE2,MLMOTX,MLMOTY,IRET)
   3 : *********************************************************************      
   4 : *                 PRODUIT SCALAIRE DE 2 CHAMELEMS                      
   5 : *********************************************************************
   6 :       IMPLICIT INTEGER(I-N)
   7 : *      IMPLICIT REAL*8(A-H,O-Z)
   8 : C--------------------------------------------------------------------        
   9 : C  ENTREE                                                                       
  10 : C     IPCHE1   CHAMELEM                                                           
  11 : C     IPCHE2   CHAMELEM                                                           
  12 : C     MLMOTX  LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER  CHAMP                
  13 : C     MLMOTY  LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHAMP                 
  14 : C  SORTIE                                                                       
  15 : C     IRET    POINTEUR SUR LE MCHAML RESULTAT                                  
  16 : C--------------------------------------------------------------------
  17 : 
  18 : -INC CCOPTIO
  19 : -INC CCHAMP
  20 : -INC SMCHAML
  21 : -INC SMELEME
  22 : -INC SMLMOTS
  23 : C
  24 :       CHARACTER*8 NOIN
  25 :       SEGMENT ITRAV                                                                                                                          
  26 :        CHARACTER*8 INCA(NINC),INCB(NINC)                                        
  27 :       ENDSEGMENT
  28 : 
  29 :      
  30 : C       
  31 :       IRET=0
  32 :       MCHAML=0
  33 : C      
  34 : C     travail  sur les listmots       
  35 :       
  36 :       MLMOTS=MLMOTX                                                             
  37 :       SEGACT MLMOTS                                                             
  38 :       NINC= MOTS(/2)                                                            
  39 :       SEGINI ITRAV                                                              
  40 :       DO 1 I = 1, NINC                                                          
  41 :       INCA(I)=MOTS(I)                                                           
  42 :   1   CONTINUE                                                                  
  43 :       SEGDES MLMOTS                                                             
  44 :       MLMOTS=MLMOTY                                                             
  45 :       SEGACT MLMOTS                                                             
  46 :         IF(MOTS(/2).NE.NINC) THEN                                                 
  47 :       SEGDES MLMOTS                                                             
  48 :       SEGSUP ITRAV                                                              
  49 :       MOTERR(1:4)='PSCA'                                                        
  50 :       MOTERR(5:12)='LISTMOTS'                                                   
  50 :       CALL ERREUR(125)                                                          
  51 :       RETURN                                                                    
  52 :         ENDIF                                                                     
  53 :       DO 21 I = 1, NINC                                                         
  54 :       INCB(I)=MOTS(I)                                                           
  55 :  21   CONTINUE                                                                  
  56 :       SEGDES MLMOTS 
  57 :       
  58 : C=========================================================
  59 : C     VERIFICATION DU LIEU SUPPORT DES MCHAML 
  60 : C       presence des      memes sous zones
  61 : C       presence des composantes declarées
  62 : C       identité  des points supports 
  63 : C
  64 : C
  65 :       MCHEL1=IPCHE1
  66 :       MCHEL2=IPCHE2      
  67 :       SEGACT MCHEL1,MCHEL2
  68 :       N1=MCHEL1.IMACHE(/1)
  69 :       NP1=MCHEL2.IMACHE(/1)
  70 : C  verification du nombre de sous zones geometriques        
  71 :        if(N1.ne.NP1)  then 
  71 :       CALL ERREUR(329)      
  72 :       segdes MCHEL1,mchel2 
  73 :       return 
  74 :        endif
  75 :        
  76 :       if(mchel1.ifoche.ne.mchel2.ifoche) then
  76 :       call erreur(21)
  77 :       segdes MCHEL1,mchel2 
  78 :       return 
  79 :        endif
  80 :       
  81 :       L1=11
  82 :       N3=6    
  83 :       SEGINI MCHEL3,MCHEL4 
  84 : C          
  85 : C   on fabrique deux CHAMPS temporaires  ordonnés        
  86 : C
  87 :       ipb1 = 0 
  88 :       DO 10  ISOUS = 1,N1 
  89 :       in1 = 0
  90 :       in2 = 0       
  91 :       IPT1 = MCHEL1.IMACHE(ISOUS)
  92 :       MCHAM1 = MCHEL1.ICHAML(ISOUS)
  93 :       SEGACT MCHAM1
  94 :       N2=NINC
  95 :       SEGINI MCHAM3,MCHAM4 
  96 :         do 16 j=1,ninc  
  97 :         do 17 k=1,MCHAM1.nomche(/2)
  98 :         noin = MCHAM1.nomche(k)
  99 :         if(noin.eq.inca(j)) then
 100 :         in1= in1 + 1    
 101 :         MCHEL3.IMACHE(isous)=IPT1
 102 :         MCHEL3.ICHAML(isous)=MCHAM3
 103 :         inf1 = mchel1.infche(isous,3)
 104 :         inf2 = mchel1.infche(isous,4) 
 105 :         melva1= MCHAM1.IELVAL(k)
 106 :         segini ,melval=melva1
 107 :         MCHAM3.IELVAL(in1)=melval
 108 :         MCHAM3.NOMCHE(in1)=noin
 109 :         segdes melva1,melval     
 110 :         goto 16
 111 :         endif
 112 : 17    continue 
 113 : 16    continue
 114 : C 
 115 :       segdes mcham1
 116 : C      
 117 :       DO 12  ii = 1,N1     
 118 :       IPT2 = MCHEL2.IMACHE(II)
 119 :             if(ipt2.eq.ipt1) then       
 120 :       MCHAM2 = MCHEL2.ICHAML(II) 
 121 :       SEGACT MCHAM2         
 122 :         do 18 j=1,ninc
 123 :         do 19 k=1,MCHAM2.nomche(/2)
 124 :         noin = MCHAM2.nomche(k)
 125 :          if(noin.eq.incb(j)) then
 126 :         in2= in2 + 1
 127 :       if(mchel2.infche(II,3).ne.inf1.or. 
 128 :      & mchel2.infche(II,4).ne.inf2) then
 129 :       ipb1 = 1 
 130 :       endif             
 131 :         MCHEL4.IMACHE(isous) = IPT2
 132 :         MCHEL4.ICHAML(isous) = MCHAM4
 133 :         melva1 = MCHAM2.IELVAL(k)
 134 :         segini , melval=melva1
 135 :         MCHAM4.IELVAL(in2) = melval
 136 :         MCHAM4.NOMCHE(in2)=noin
 137 :         segdes melva1,melval    
 138 :         goto 18         
 139 :          endif
 140 : 19    continue 
 141 : 18    continue 
 142 :         segdes mcham2        
 143 :              endif
 144 : 12    CONTINUE 
 145 :       if(ipb1.eq.1) then 
 146 :       moterr(1:8) = MCHEL1.TITCHE(1:8) 
 147 :       moterr(9:16)= MCHEL2.TITCHE(1:8) 
 148 :       segdes mchel1,mchel2
 149 :       segsup MCHAM3,MCHAM4,MCHEL3,MCHEL4,itrav             
 149 :       call erreur(175)
 150 :       RETURN
 151 :       endif
 152 : C======       
 153 :       if(in1.ne.ninc.or.in2.ne.ninc) then
 154 :       segdes mchel1,mchel2      
 155 :       segsup MCHAM3,MCHAM4,MCHEL3,MCHEL4,itrav      
 156 : C      write(6,*) ' incoherence entre composantes et listmots   '
 156 :       call erreur(911)       
 157 :       RETURN
 158 :         endif 
 159 : C====== 
 160 : 10    CONTINUE
 161 : C
 162 :       segsup itrav 
 163 :       if (mchel1.ne.mchel2) segdes mchel2
 164 : 
 165 :        
 166 : C----------------------------------------------------------          
 167 : C
 168 : C     CREATION DU MCHELM
 169 : C
 170 :       L1=11 
 171 :       N3=6
 172 : C
 173 :       SEGINI MCHELM
 174 :       TITCHE='PROSCAL'
 175 :             
 176 :       IFOCHE=MCHEL1.IFOCHE
 177 :       IRET=MCHELM
 178 : C____________________________________________________________________
 179 : C
 180 : C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
 181 : C____________________________________________________________________
 182 : C
 183 :       DO 500 ISOUS=1,N1
 184 : *
 185 : *   INITIALISATION
 186 : *
 187 :  
 188 :       MELEME = MCHEL1.IMACHE(ISOUS)      
 189 :       IMACHE(ISOUS)= MELEME 
 190 :       CONCHE(ISOUS)= MCHEL1.CONCHE(ISOUS) 
 191 : C      
 192 : C    
 193 :       INFCHE(ISOUS,1)=0
 194 :       INFCHE(ISOUS,2)=0
 195 :       INFCHE(ISOUS,3)=MCHEL1.INFCHE(ISOUS,3)
 196 :       INFCHE(ISOUS,4)=MCHEL1.INFCHE(ISOUS,4)
 197 :       INFCHE(ISOUS,5)=0
 198 :       INFCHE(ISOUS,6)=MCHEL1.INFCHE(ISOUS,6)
 199 : C
 200 : C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
 201 : C     bp (septembre 2009): modif pour permettre d'avoir des zones de champs
 202 : C     cst et d'autres variables => differentes tailles de supports
 203 : C 
 204 :       MCHAM3=MCHEL3.ICHAML(ISOUS)
 205 :       MCHAM4=MCHEL4.ICHAML(ISOUS)         
 206 :       N1PTEL = 0
 207 :       N1EL   = 0
 208 :       DO ICOMP=1,NINC
 209 :         MELVA1 = MCHAM3.IELVAL(ICOMP)
 210 :         MELVA2 = MCHAM4.IELVAL(ICOMP)
 211 :         SEGACT MELVA1,MELVA2 
 212 :         N1PTEL = max(N1PTEL,MELVA1.VELCHE(/1))
 213 :         N1EL   = max(N1EL,MELVA1.VELCHE(/2))
 214 :         SEGDES MELVA1,MELVA2 
 215 :       ENDDO
 216 : C
 217 : C     CREATION DU MCHAML RESULTAT DE LA SOUS ZONE
 218 : C
 219 :       N2=1
 220 :       SEGINI MCHAML
 221 :       ICHAML(ISOUS)=MCHAML
 222 : 
 223 :         NOMCHE(1)='SCAL'
 224 :         TYPCHE(1)='REAL*8'
 225 :         N2PTEL=0
 226 :         N2EL=0
 227 :         SEGINI MELVAL
 228 :         IELVAL(1)=MELVAL
 229 : c      mise a 0 initiale (necessaire?)
 230 :        DO  IE= 1,N1EL
 231 :        DO  IB= 1,N1PTEL
 232 :          VELCHE(IB,IE) = 0.D0 
 233 :        ENDDO     
 234 :        ENDDO    
 235 : C
 236 :        DO 110  ICOMP=1,NINC
 237 :          MELVA1= MCHAM3.IELVAL(ICOMP)
 238 :          MELVA2= MCHAM4.IELVAL(ICOMP)
 239 :          segact melva1,melva2
 240 :          IB1MAX = MELVA1.VELCHE(/1)
 241 :          IE1MAX = MELVA1.VELCHE(/2)
 242 :          IB2MAX = MELVA2.VELCHE(/1)
 243 :          IE2MAX = MELVA2.VELCHE(/2)
 244 : c         write(6,*) 'comp',MCHAM3.NOMCHE(icomp),MCHAM4.NOMCHE(icomp)
 245 : C        write(6,*) 'melvals' ,melva1,melva2 
 246 :          DO  IE= 1,N1EL
 247 :          DO  IB= 1,N1PTEL
 248 :            IB1 = min(IB,IB1MAX)
 249 :            IB2 = min(IB,IB2MAX)
 250 :            IE1 = min(IE,IE1MAX)
 251 :            IE2 = min(IE,IE2MAX)
 252 : c           write(6,*) 'VELCHE(IB,IE) = ',VELCHE(IB,IE),' + ', 
 253 : c     &     (MELVA1.VELCHE(IB1,IE1)),' * ',(MELVA2.VELCHE(IB2,IE2))
 254 :            VELCHE(IB,IE) = VELCHE(IB,IE) 
 255 :      &     + MELVA1.VELCHE(IB1,IE1)*MELVA2.VELCHE(IB2,IE2)
 256 :          ENDDO     
 257 :          ENDDO    
 258 :        segdes melva1,melva2                     
 259 : 110    CONTINUE
 260 : C
 261 : C      segsup MCHAM3,MCHAM4
 262 :       segdes,MELVAL,MCHAML
 263 :  
 264 : 500   CONTINUE
 264 :       call dtcham(mchel3)
 264 :       call dtcham(mchel4) 
 265 :       segdes mchel1,mchelm     
 266 :       RETURN
 267 :       END
 268 : 
 269 : 
 270 :