1 : C KREMP2 SOURCE CHAT 05/01/13 01:06:22 5004 2 : SUBROUTINE KREMP2 (K1,K2,O1,A2,C,U2,SHC2D,SKBUF2,SKRESO) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C 6 : C DIM 2 INTERIEUR D'UN CONTOUR 7 : C ------------------------------ 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 : C----------------------------------------------------------------------- 36 : SEGMENT SKBUF2 37 : INTEGER NUMF(NFC,NOC,NR),NTYP(NFC,NR) 38 : REAL*8 ZB(NFC,NR),PSC(NFC,NR) 39 : ENDSEGMENT 40 : C 41 : C BUFFER ASSOCIE AU H.C 42 : C --------------------- 43 : C NUMF : INDICE DE LE DERNIERE FACE RENCONTREE 44 : C NTYP : TYPES ASSOCIES 45 : C ZB : PROFONDEUR 46 : C PSC : PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE) 47 : C----------------------------------------------------------------------- 48 : DIMENSION O1(2),X1(2),X2(2),U2(1) 49 : DIMENSION X(2),XR(2),XR1(2),XR2(2) 50 : DIMENSION A2(2,2) 51 : C 52 : DO 100 K=1,2 53 : X1(K)=A2(K,1) 54 : X2(K)=A2(K,2) 55 : 100 CONTINUE 56 : C 57 : IF (KIMP.GE.4) WRITE(6,*) ' X1 ',X1(1),X1(2),' X2 ',X2(1),X2(2) 58 : C 59 : C PROJECTION DES 2 SOMMETS 60 : C 60 : CALL KAPCU2(KES,X1,O1,NRES,XR1,NF1,LS1) 61 : IF (KIMP.GE.4) WRITE(6,*) ' NF1 LS1 XR1 ',NF1,LS1,XR1(1),XR1(2) 62 : 62 : CALL KAPCU2(KES,X2,O1,NRES,XR2,NF2,LS2) 63 : IF (KIMP.GE.4) WRITE(6,*) ' NF2 LS2 XR2 ',NF2,LS2,XR2(1),XR2(2) 64 : 64 : CALL KREMS2(K2,NF1,LS1,C,U2,SHC2D,SKBUF2,SKRESO) 64 : CALL KREMS2(K2,NF2,LS2,C,U2,SHC2D,SKBUF2,SKRESO) 65 : C 66 : IF(NF1.EQ.NF2) THEN 67 : C 68 : C UNE SEULE FACE 69 : C -------------- 70 : LMIN = MIN0(LS1,LS2) 71 : LMAX = MAX0(LS1,LS2) 72 : IF((LMAX-LMIN).GE.2 ) THEN 72 : CALL K2EMPI(K2,NF1,LMIN+1,LMAX-1,C,U2,SHC2D,SKBUF2,SKRESO) 73 : ENDIF 74 : 75 : ELSE 76 : C 77 : C DEUX FACES DIFFERENTES 1) PARALLELES 2) NON PARALLELES 78 : C --------------------------------------------------------- 79 : IF (KA(NF1).EQ.KA(NF2)) THEN 80 : IF (KIMP.GE.4) WRITE(6,*) ' KREMP2 CAS PARALLELE' 81 : KAC = KA(NF1) 82 : DO 1 K=1,KES 83 : X(K) = (X1(K)+X2(K))/2 84 : 1 CONTINUE 85 : IF(KIMP.GE.4) WRITE(6,*) ' X ',X(1),X(2) 86 : 87 : II = 0 88 : 10 CONTINUE 89 : II = II + 1 90 : 91 : IF (II.GE.12) THEN 92 : WRITE(6,*) ' non convergence de la dichotomie' 93 : RETURN 94 : ELSEIF (II.GE.10) THEN 95 : 96 : IF((NF1.EQ.1).OR.(NF1.EQ.2)) X(1)=O1(1) 97 : IF((NF1.EQ.3).OR.(NF1.EQ.4)) X(2)=O1(2) 98 : 99 : ENDIF 100 : 100 : CALL KAPC21(KES,X,O1,NRES,XR,NF,LS,KAC) 101 : 102 : IF (NF.EQ.NF1) THEN 103 : 104 : DO 2 K = 1,KES 105 : X(K) = (X(K)+X2(K))/2 106 : 2 CONTINUE 107 : GOTO 10 108 : ELSE 109 : IF(NF.EQ.NF2) THEN 110 : DO 3 K = 1,KES 111 : X(K) = (X1(K)+X(K))/2 112 : 3 CONTINUE 113 : GOTO 10 114 : ELSE 115 : IF (KIMP.GE.4) WRITE(6,*) ' FACE GENEREE ',NF 116 : C 117 : C NF EST <> NF1 ET <>NF2 118 : C 119 : C --- 120 : LEX = IM(NF1,NF) 121 : IF (LEX.EQ.0) THEN 122 : WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 1' 123 : ENDIF 124 : KELT = LEX-LS1 125 : IF (KELT.GE.1 ) THEN 125 : CALL K2EMPI(K2,NF1,LS1+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO) 126 : ENDIF 127 : IF (KELT.LE.-1) THEN 127 : CALL K2EMPI(K2,NF1,LEX,LS1+1,C,U2,SHC2D,SKBUF2,SKRESO) 128 : ENDIF 129 : 130 : LEX = IM(NF2,NF) 131 : IF (LEX.EQ.0) THEN 132 : WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 2' 133 : ENDIF 134 : KELT = LEX-LS2 135 : IF (KELT.GE.1 ) THEN 135 : CALL K2EMPI(K2,NF2,LS2+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO) 136 : ENDIF 137 : IF (KELT.LE.-1) THEN 137 : CALL K2EMPI(K2,NF2,LEX,LS2+1,C,U2,SHC2D,SKBUF2,SKRESO) 138 : ENDIF 139 : 139 : CALL K2EMPI(K2,NF,1,NRES,C,U2,SHC2D,SKBUF2,SKRESO) 140 : C 141 : ENDIF 142 : ENDIF 143 : C 144 : ELSE 145 : IF (KIMP.GE.4) WRITE(6,*) ' KREMP2 FACES NON PARALLES ' 146 : LEX = IM(NF1,NF2) 147 : IF (LEX.EQ.0) THEN 148 : WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 3' 149 : ENDIF 150 : KELT = LEX-LS1 151 : IF (KELT.GE.1 ) THEN 151 : CALL K2EMPI(K2,NF1,LS1+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO) 152 : ENDIF 153 : IF (KELT.LE.-1) THEN 153 : CALL K2EMPI(K2,NF1,LEX,LS1-1,C,U2,SHC2D,SKBUF2,SKRESO) 154 : ENDIF 155 : C 156 : LEX = IM(NF2,NF1) 157 : IF (LEX.EQ.0) THEN 158 : WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 4' 159 : ENDIF 160 : KELT = LEX-LS2 161 : IF (KELT.GE.1 ) THEN 161 : CALL K2EMPI(K2,NF2,LS2+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO) 162 : ENDIF 163 : IF (KELT.LE.-1) THEN 163 : CALL K2EMPI(K2,NF2,LEX,LS2-1,C,U2,SHC2D,SKBUF2,SKRESO) 164 : ENDIF 165 : ENDIF 166 : ENDIF 167 : 168 : RETURN 169 : END 170 : 171 :
© Cast3M 2003 - All rights reserved.
Disclaimer