Esope source files

   1 : C K2EMPI    SOURCE    CHAT      05/01/13    00:50:17     5004           
   2 :       SUBROUTINE K2EMPI (K2,NF,LMIN,LMAX,C,U2,SHC2D,SKBUF2,SKRESO)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   5 : C                                                                               
   6 : C     DIM 2  : INTERIEU                                                         
   7 : C     ON SUPPOSE LMIN < LMAX                                                    
   8 : C
   9 : C-----------------------------------------------------------------------
  10 :       SEGMENT SKRESO
  11 :       INTEGER KFC,NRES,KES,KIMP
  12 :       ENDSEGMENT
  13 : C     KFC : NOMBRE DE FACES H.C                                                 
  14 : C     NRES: RESOLUTION                                                          
  15 : C     KES : DIM ESPACE                                                          
  16 : C     KIMP: IMPRESSION                                                          
  17 : C-----------------------------------------------------------------------
  18 : C-----------------------------------------------------------------------
  19 :       SEGMENT SHC2D                                                             
  20 :       INTEGER IR(NR),KA(NFC),IM(NFC,NFC)                                        
  21 :       INTEGER KRO(NFC,NES),KSI(NFC,NES)                                         
  22 :       REAL*8  V(NES,NR),G(NR)                                                   
  23 :       ENDSEGMENT                                                                
  24 : 
  25 : C     DESCRIPTION DU H.C DE PROJECTION                                          
  26 : C     --------------------------------                                          
  27 : C     V : DIRECTION UNITAIRE DES CELLULES                                       
  28 : C     G : FACTEUR DE FORME ASSOCIE                                              
  29 : C     IR: CORRESPONDANCE                                                        
  30 : C     KRO , KSI : POUR LE CHANGEMENT DE REPERE                                  
  31 : C     IM  : REFERENCE                                                           
  32 : C     NR  : RESOLUTION
  33 : C     NFC : NOMBRE DE FACES
  34 : C-----------------------------------------------------------------------
  35 :       SEGMENT SKBUF2                                                            
  36 :       INTEGER  NUMF(NFC,NOC,NR),NTYP(NFC,NR)                                    
  37 :       REAL*8   ZB(NFC,NR),PSC(NFC,NR)                                           
  38 :       ENDSEGMENT                                                                
  39 : C                                                                               
  40 : C     BUFFER ASSOCIE AU H.C                                                     
  41 : C     ---------------------                                                     
  42 : C     NUMF : INDICE DE LE DERNIERE FACE RENCONTREE                              
  43 : C     NTYP :  TYPES ASSOCIES                                                    
  44 : C     ZB  : PROFONDEUR                                                          
  45 : C     PSC  :  PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE)                      
  46 : C-----------------------------------------------------------------------
  47 :       DIMENSION U2(1)                                                           
  48 : C                                                                               
  49 :       LL = LMAX-LMIN + 1                                                        
  50 :       IF (KIMP.GE.4) WRITE(6,*) '  NF  NINT ',NF, LL
  51 :       DO 404 I = LMIN,LMAX                                                      
  52 :            IF (PSC(NF,I).GT.-1.) THEN                                           
  53 :               B = 0.                                                            
  54 :               DO 406  IES = 1,KES                                               
  55 :               B = B + U2(IES)*KSI(NF,IES)*V(KRO(NF,IES),I)                      
  56 :  406          CONTINUE                                                          
  57 :               IF (DABS(B).GT.0.0001) THEN                                       
  58 :                  Z = - C / B                                                    
  59 :                  IF (Z.LT.ZB(NF,I).AND.Z.GT.1E-4)  THEN                         
  60 :                     ZB(NF,I) = Z                                                
  61 :                     NUMF(NF,1,I) = K2                                           
  62 :                     NTYP(NF,I) = 1                                              
  63 :                  ENDIF                                                          
  64 :               ENDIF                                                             
  65 :             ENDIF                                                               
  66 :  404        CONTINUE                                                            
  67 :       RETURN                                                                    
  68 :       END                                                                       
  69 :