Esope source files

   1 : C KRCOMB    SOURCE    CHAT      05/01/13    01:06:06     5004           
   2 :       SUBROUTINE KRCOMB (K1,SP1,SHC3D,SKFACE,SKBUFF,EXTINC)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   5 : C----------------------------------------------------------------------
   6 : C Calcul des facteurs de forme en 3D
   7 : C Sp appele par FACGEN
   8 : C
   9 : C     RECOMBINAISON                                                             
  10 : C     -------------                                                             
  11 : C     CONTRIBUTION DUE A UN PATCH DONNE                                         
  12 : C----------------------------------------------------------------------
  13 : -INC TFFOR3D
  14 : C                                                                               
  15 :       MFACE = FF1(/1)                                                           
  16 :       DO 400 K = 1,MFACE                                                        
  17 :       FF1(K) = 0.                                                               
  18 :  400  CONTINUE                                                                  
  19 :                                                                                 
  20 :       NC = 0                                                                    
  21 : 
  22 :       IF(EXTINC.GT.1D-3) THEN
  23 : C
  24 : C     milieu absorbant
  25 : 
  26 :       DO 500 NF = 1,KFC                                                         
  27 :       DO 501 I = 1,NRES                                                         
  28 :       DO 502 J = 1,NRES                                                         
  29 :                                                                                 
  30 :          NTY = NTYP(NF,I,J)                                                     
  31 :          IF ( (NTY.NE.0) .AND. (PSC(NF,I,J).GT.-1.) ) THEN                      
  32 :            NC = NC + 1                                                          
  33 :            PROD  =  PSC(NF,I,J)*G(I,J)                                          
  34 :              DO 503 KT=1,NTY
  35 :               K = NUMF(NF,KT,I,J)                                               
  36 :               FF1(K) = FF1(K) + (PROD/NTY)*DEXP(-EXTINC*ZB(NF,I,J))
  37 :  503         CONTINUE
  38 :          ENDIF                                                                  
  39 :  502  CONTINUE                                                                  
  40 :  501  CONTINUE                                                                  
  41 :  500  CONTINUE                                                                  
  42 : 
  43 :       ELSE
  44 : C
  45 : C     milieu transparent
  46 : 
  47 :       DO 600 NF = 1,KFC
  48 :       DO 601 I = 1,NRES
  49 :       DO 602 J = 1,NRES
  50 :                                                                                 
  51 :          NTY = NTYP(NF,I,J)                                                     
  52 :          IF ( (NTY.NE.0) .AND. (PSC(NF,I,J).GT.-1.) ) THEN                      
  53 :            NC = NC + 1                                                          
  54 :            PROD  =  PSC(NF,I,J)*G(I,J)                                          
  55 :              DO 603 KT=1,NTY
  56 :               K = NUMF(NF,KT,I,J)                                               
  57 :               FF1(K) = FF1(K) + PROD/NTY                                        
  58 :  603         CONTINUE
  59 :          ENDIF                                                                  
  60 :  602  CONTINUE
  61 :  601  CONTINUE
  62 :  600  CONTINUE
  63 : 
  64 :       ENDIF
  65 : 
  66 :       NCELL(K1) = NC                                                            
  67 :                                                                                 
  67 :       CALL UTSOMM(FF1,MFACE,FFT)                                                
  68 :       IF (KIMP.GE.4) THEN
  69 :       WRITE(6,1000) K1,SP1,NCELL(K1),FFT                                        
  70 :  1000 FORMAT(1X,' K1 ',I4,' SP1 ',E12.5,'NCELL ',I6,' FFT ',F10.5)              
  71 :       ENDIF                                                                     
  72 : C                                                                               
  73 :       DO 700 K = 1,MFACE
  74 :       FF1(K) = SP1 * FF1(K)                                                     
  75 :  700  CONTINUE
  76 : C                                                                               
  77 :       RETURN                                                                    
  78 :       END                                                                       
  79 :  
  80 :  
  81 :  
  82 :  
  83 :