1 : C BIOKAM SOURCE CHAT 05/01/12 21:40:13 5004 2 : SUBROUTINE BIOKAM(MCHPO1,IPT1,ENT) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : -INC CCOPTIO 6 : -INC CCREEL 7 : -INC SMELEME 8 : -INC SMCOORD 9 : -INC SMCHPOI 10 : -INC TMTRAV 11 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 12 : SEGMENT STAB 13 : REAL*8 ICOS(INMAX), INTELL(INM,6) 14 : END SEGMENT 15 : INTEGER ENTIER,ENT,I,IVAL,NMAX,NM 16 : character*4 ichaine 17 : DIMENSION TAB1(101),TAB2(101) 18 : 19 : NMAX=50 20 : NM=99 21 : NE=NM+1 22 : 23 : C============================================ 24 : C ON COMMENCE PAR EXPLORER LE MAILLAGE = 25 : C============================================ 26 : SEGACT IPT1 26 : IF (IPT1.ITYPEL.NE.1.OR.IPT1.LISOUS(/1).NE.0) CALL CHANGE(IPT1,1) 27 : 28 : C============================================================== 29 : C ON VERIFIE QUE CHAQUE POINT N'APPARAIT QU'UNE SEULE FOIS = 30 : C============================================================== 31 : 32 : NNNOE=IPT1.NUM(/2) 33 : SEGINI ICPR 34 : ICON=0 35 : DO 1 I=1,NNNOE 36 : IKI=IPT1.NUM(1,I) 37 : IF(ICPR(IKI).NE.0) GO TO 1 38 : ICON=ICON+1 39 : ICPR(IKI)=ICON 40 : 1 CONTINUE 41 : SEGSUP ICPR 42 : 43 : IF(ICON.NE.NNNOE) THEN 43 : CALL ERREUR(75) 44 : SEGDES IPT1 45 : RETURN 46 : ENDIF 47 : 48 : 49 : 50 : C=========================================== 51 : C INITIALISATION DES NOMS DES COMPOSANTES = 52 : C=========================================== 53 : 54 : NNIN=IDIM+1 55 : SEGINI MTRAV 56 : NHRM=NIFOUR 57 : IF (NIFOUR.EQ.1) NHRM=IFOUR 58 : INCO(1)='BX ' 59 : INCO(2)='BY ' 60 : INCO(3)='BZ ' 61 : INCO(4)='FLUX' 62 : NHAR(1)=NHRM 63 : NHAR(2)=NHRM 64 : NHAR(3)=NHRM 65 : NHAR(4)=NHRM 66 : 67 : 68 : C================================================ 69 : C REMPLISSAGE DE TAB1(T_ELIP) ET TAB2(T_DELIP) = 70 : C================================================ 71 : 72 : 72 : CALL ELPTI7 (NMAX,NM,ENTIER) 73 : STAB=ENTIER 74 : SEGACT STAB 75 : TAB1(1)=0. 76 : TAB2(1)=0. 77 : DO I=1,NE 78 : A=INTELL(I,2) 79 : AV=0.5*(REAL(I)-1.)/NE 80 : TAB1(I)=A+(0.707107*(LOG(1.-(4*AV*AV))))-(0.3127313*AV*AV) 81 : IF (I.GE.3) THEN 82 : TAB2(I-1)=(TAB1(I)-TAB1(I-2))*NE 83 : END IF 84 : END DO 85 : TAB1(NE+1)=(3*(TAB1(NE)-TAB1(NE-1)))+TAB1(NE-2) 86 : TAB2(NE)=(TAB1(NE+1)-TAB1(NE-1))*NE 87 : TAB2(NE+1)=(2*TAB2(NE))-TAB2(NE-1) 88 : SEGDES STAB 89 : 90 : C============================ 91 : C ON BOUCLE SUR LES NOEUDS = 92 : C============================ 93 : SEGACT MCHPO1 94 : DO 2 IPT=1,NNNOE 95 : L=IPT1.NUM(1,IPT) 96 : IREF= (IDIM+1)*L 97 : XM=XCOOR (IREF-IDIM) 98 : YM=XCOOR (IREF-IDIM+1) 99 : ZM=XCOOR (IREF-IDIM+2) 100 : RM=((XM**2)+(YM**2))**0.5 101 : C write(6,*) 'RM=',RM 102 : if ( xm.eq.0 ) then 103 : if ( ym.gt.0 ) then 104 : theta = xpi/2. 105 : else 106 : if ( ym.lt.0 ) then 107 : theta = -1.*xpi/2. 108 : else 109 : theta = 1. 110 : end if 111 : end if 112 : else 113 : THETA= ATAN(YM/XM) 114 : end if 115 : 116 : C LECTURE DU CHAMP POINT 117 : BX=0. 118 : BY=0. 119 : BZ1=0. 120 : FLU=0. 121 : DO 3 I=1,MCHPO1.IPCHP(/1) 122 : MSOUPO=MCHPO1.IPCHP(I) 123 : SEGACT MSOUPO 124 : IPT3=IGEOC 125 : SEGACT IPT3 126 : MPOVAL=IPOVAL 127 : SEGACT MPOVAL 128 : c write (6,*) 'nbr compo =' ,nocomp(/2) 129 : 130 : DO 4 K=1,IPT3.NUM(/2) 131 : L1=IPT3.NUM(1,K) 132 : IREF1=(IDIM+1)*L1 133 : X=XCOOR (IREF1-IDIM) 134 : Y=XCOOR (IREF1-IDIM+1) 135 : Z=XCOOR (IREF1-IDIM+2) 136 : if (nocomp(/2).eq.0) then 137 : H = 1.e-5 138 : COUR = 1. 139 : end if 140 : if (nocomp(/2).eq.1) then 141 : if (nocomp(1).eq.'E ') then 142 : H = vpocha(k,1) 143 : COUR = 1. 144 : else 145 : if (nocomp(1).eq.'I ') then 146 : H = 1.e-5 147 : COUR = vpocha(k,1) 148 : else 148 : call erreur (961) 149 : end if 150 : end if 151 : end if 152 : if ( nocomp(/2).eq.2) then 153 : if ((nocomp(1).eq.'E ').and.(nocomp(2).eq.'I ')) then 154 : H=VPOCHA(K,1) 155 : COUR=VPOCHA(K,2) 156 : else 157 : if ((nocomp(1).eq.'I ').and.(nocomp(2).eq.'E ')) then 158 : H=VPOCHA(K,2) 159 : COUR=VPOCHA(K,1) 160 : else 160 : call erreur (961) 161 : end if 162 : end if 163 : end if 164 : R=((X**2)+(Y**2))**0.5 165 : FLU=FLU + (COUR*(FLUXBC(RM,ZM,R,Z,H,NE,TAB1)/1.E+6)) 165 : CALL CHAMPM(RM,ZM,R,Z,H,NE,TAB1,TAB2,BR,BZ) 166 : IF (XM.LT.0) THEN 167 : BX=BX- ( COUR*(BR/1.E+6)*COS (THETA)) 168 : BY=BY- ( COUR*(BR/1.E+6)*SIN (THETA)) 169 : BZ1=BZ1 + (COUR*(BZ/1.E+6)) 170 : ELSE 171 : BX=BX+ ( COUR*(BR/1.E+6)*COS (THETA)) 172 : BY=BY+ ( COUR*(BR/1.E+6)*SIN (THETA)) 173 : BZ1= BZ1 + ( COUR*(BZ/1.E+6)) 174 : END IF 175 : 4 CONTINUE 176 : SEGDES MPOVAL 177 : SEGDES IPT3 178 : SEGDES MSOUPO 179 : 3 CONTINUE 180 : C WRITE(6,*) 'FLU=',FLU 181 : C WRITE(6,*) 'BX= ',BX,';BY= ',BY,';BZ= ',BZ1 182 : IGEO(IPT)=L 183 : BB(1,IPT)=BX 184 : IBIN(1,IPT)=1 185 : BB(2,IPT)=BY 186 : IBIN(2,IPT)=1 187 : BB(3,IPT)=BZ1 188 : IBIN(3,IPT)=1 189 : BB(4,IPT)=FLU 190 : IBIN(4,IPT)=1 191 : 2 CONTINUE 192 : SEGDES IPT1 193 : 193 : CALL CRECHP(MTRAV,MCHPO3) 194 : ENT=MCHPO3 195 : SEGSUP MTRAV 196 : C WRITE(6,*) 'COUCOU1',ENT 197 : RETURN 198 : END 199 : 200 : 201 : 202 :
© Cast3M 2003 - All rights reserved.
Disclaimer