1 : C COAC SOURCE CHAT 06/03/29 21:17:03 5360 2 : SUBROUTINE COAC 3 : C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 4 : C 5 : C OPERATEUR COAC 6 : C 7 : C CALCULE LE COEFFICIENT D'ACTIVITE ( DANS UNE SOLUTION CHIMIQUE) 8 : C 9 : C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 10 : IMPLICIT INTEGER(I-N) 11 : IMPLICIT REAL*8(A-H,O-Z) 12 : CHARACTER*8 MOCLE(2) 13 : CHARACTER*4 NOMTOT 14 : -INC CCOPTIO 15 : -INC SMLENTI 16 : -INC SMLMOTS 17 : -INC SMCHPOI 18 : -INC SMELEME 19 : POINTEUR MLAA.MLREEL,MLOGK.MLREEL,MLFF.MLREEL 20 : POINTEUR MLIDX.MLENTI,MLIDY.MLENTI,MLIDZ.MLENTI,MLIDP.MLENTI 21 : POINTEUR MLNN.MLENTI,MLDECY.MLENTI 22 : POINTEUR MLIONZ.MLENTI,MLPREC.MLENTI 23 : POINTEUR MLNAME.MLMOTS,MLNESP.MLMOTS 24 : POINTEUR MLSOLU.MLENTI,MMSOLU.MLMOTS 25 : POINTEUR MCOACT.MCHPOI,ICOACT.MPOVAL 26 : POINTEUR MCHTMP.MCHPOI,ICHTMP.MPOVAL 27 : CHARACTER*8 TYPEMA 28 : SEGMENT IDSCHI 29 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 30 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 31 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 32 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 33 : ENDSEGMENT 34 : SEGMENT SP2 35 : REAL*8 GX(NXDIM),XX(NXDIM),GS(NZDIM),SS(NZDIM) 36 : REAL*8 TOT(NXDIM),TOTAQ(NXDIM),TOTFIX(NXDIM),GKS(NZDIM) 37 : REAL*8 YY(NXDIM),ZZ(NXDIM,NXDIM),CC(NYDIM),GC(NYDIM) 38 : ENDSEGMENT 39 : DATA MOCLE/'FORCEION','TEMPERAT'/ 40 : C 41 : C 42 : C LECTURE DE LA TABLE CHIMI1 42 : CALL CHMDEB(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY, 43 : * MLNAME,MLIONZ,ITIDEN,ITREDO,ITEMPE,MLNESP) 44 : IF(IERR.NE.0)RETURN 45 : C 46 : C LECTURE DE LA TABLE IDEN 47 : C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL 48 : C 48 : CALL CHMIDE(ITIDEN,MLCOMP,MLSOLU,MMSOLU,MLPREC,MMPREC,MLSURF, 49 : * MMSURF,MLTYP3,MMTYP3,MLTYP6,MMTYP6,MLPARF,MLREAC,MLIMMO, 50 : * MLPOLE,MMPOLE,MLSOSO,MMSOSO,LIMP3) 51 : IF(IERR.NE.0)RETURN 52 : C 53 : C 54 : C LECTURE DE LA TABLE TEMPE(SI ELLE EXISTE) 55 : C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL 55 : CALL CHMTET(ITEMPE,LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5) 56 : IF(IERR.NE.0)RETURN 57 : LTMP=0 58 : IF(LGKMOD.NE.0)LTMP=IP3 59 : C 60 : C 61 : JCHTMP=0 62 : ILIR=1 63 : 10 CONTINUE 64 : ICOND=ILIR 64 : CALL LIRMOT(MOCLE,2,IRAN,ICOND) 65 : IF(IERR.NE.0)RETURN 66 : IF(IRAN.EQ.1)THEN 67 : C 68 : C 69 : C LECTURE DU CHPOIN DES FORCES IONIQUES 70 : C 70 : CALL LIROBJ('CHPOINT',MCHPOI,0,IRETOU) 71 : IF(IRETOU.EQ.0)THEN 71 : CALL ERREUR(21) 72 : RETURN 73 : ENDIF 74 : SEGACT MCHPOI 75 : NSOUPO=IPCHP(/1) 76 : IF(NSOUPO.NE.1)THEN 76 : CALL ERREUR(21) 77 : RETURN 78 : ENDIF 79 : ILIR=ILIR-1 80 : GO TO 10 81 : ENDIF 82 : IF(IRAN.EQ.2)THEN 83 : C 84 : C 85 : C LECTURE DU CHPOIN DES TEMPERATURES 86 : C 86 : CALL LIROBJ('CHPOINT',JCHTMP,0,IRETOU) 87 : IF(IRETOU.EQ.0)THEN 87 : CALL ERREUR(21) 88 : RETURN 89 : ENDIF 90 : GO TO 10 91 : ENDIF 92 : MSOUPO=IPCHP(1) 93 : SEGACT MSOUPO 94 : MELEME=IGEOC 95 : IF(JCHTMP.NE.0)THEN 96 : INDIQ=1 97 : NBCOMP=-1 98 : NOMTOT=' ' 98 : CALL QUEPOI(JCHTMP,MELEME,INDIQ,NBCOMP,NOMTOT) 99 : IF(INDIQ.LT.0)THEN 99 : CALL ERREUR(22) 100 : ENDIF 101 : IF(IERR.NE.0)RETURN 102 : MCHTMP=JCHTMP 102 : CALL LICHT(MCHTMP,ICHTMP,TYPEMA,IGEOM) 103 : ENDIF 104 : MPOVAL=IPOVAL 105 : SEGACT MPOVAL 106 : NPN=VPOCHA(/1) 107 : 108 : C 109 : C ON ACTIVE LES SEGMENTS 110 : C ET ON DEFINIT LES TABLEAUX DE TRAVAIL 111 : SEGACT MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP 112 : SEGACT MLIONZ,MLIDP 113 : NXDIM=MLIDX.LECT(/1) 114 : NYDIM=MLIDY.LECT(/1) 115 : NZDIM=MLIDZ.LECT(/1) 116 : NPDIM=MLIDP.LECT(/1) 117 : SEGINI IDSCHI 118 : SEGINI SP2 119 : C 120 : C LE CHPOINT RESULTAT 121 : JGM=1 122 : JGN=4 123 : SEGINI MLMOTS 124 : MOTS(1)='SCAL' 124 : CALL CHMCRC(MLMOTS,MELEME,NPN,MCOACT,ICOACT) 125 : SEGSUP MLMOTS 126 : C 127 : C INITIALISATION 128 : SEGACT MELEME 129 : 130 : C 131 : C ------------------------------------------------------------------- 132 : C BOUCLE SUR LES POINTS 133 : C ------------------------------------------------------------------- 134 : DO 100 II=1,NPN 135 : C CHARGEMENT DE IDSCHI 135 : CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY, 136 : * MLNAME,MLIONZ,IDSCHI,MLNESP) 137 : C WRITE(6,*)' GK apres CHMIDS ' 138 : C WRITE(6,120)(GK(J),IDY(J),J=1,NYDIM) 139 : 120 FORMAT(6(1X,1PD12.5,I5)) 140 : C 141 : XMU=0.D0 142 : XMUNEW=VPOCHA(II,1) 143 : TMP=25.D0 144 : TMPNEW=25.D0 145 : IF(JCHTMP.NE.0)TMPNEW=ICHTMP.VPOCHA(II,1) 145 : CALL CHMMOD(IDSCHI,XMU,XMUNEW,TMPNEW,GNEW) 146 : ICOACT.VPOCHA(II,1)=GNEW 147 : 100 CONTINUE 148 : C -------------------------------------------------------------- 149 : C LE MENAGE 150 : C 151 : SEGSUP IDSCHI 152 : SEGSUP SP2 153 : C 154 : C ON DESACTIVE LES DONNEES 155 : SEGDES MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP 156 : SEGDES MLIONZ,MLIDP 157 : SEGDES MELEME 158 : MLENTI=MLCOMP 159 : SEGDES MLENTI 160 : IF(MLSOSO.NE.0)THEN 161 : MLENTI=MLSOSO 162 : MLMOTS=MMSOSO 163 : SEGDES MLENTI,MLMOTS 164 : ENDIF 165 : IF(MLPOLE.NE.0)THEN 166 : MLENTI=MLPOLE 167 : MLMOTS=MMPOLE 168 : SEGDES MLENTI,MLMOTS 169 : ENDIF 170 : IF(MLSOLU.NE.0)THEN 171 : MLENTI=MLSOLU 172 : MLMOTS=MMSOLU 173 : SEGDES MLENTI,MLMOTS 174 : ENDIF 175 : IF(MLPREC.NE.0)THEN 176 : MLENTI=MLPREC 177 : MLMOTS=MMPREC 178 : SEGDES MLENTI,MLMOTS 179 : ENDIF 180 : IF(MLSURF.NE.0)THEN 181 : MLENTI=MLSURF 182 : MLMOTS=MMSURF 183 : SEGDES MLENTI,MLMOTS 184 : ENDIF 185 : IF(MLTYP3.NE.0)THEN 186 : MLENTI=MLTYP3 187 : MLMOTS=MMTYP3 188 : SEGDES MLENTI,MLMOTS 189 : ENDIF 190 : IF(MLTYP6.NE.0)THEN 191 : MLENTI=MLTYP6 192 : MLMOTS=MMTYP6 193 : SEGDES MLENTI,MLMOTS 194 : ENDIF 195 : IF(MLPARF.NE.0)THEN 196 : MLENTI=MLPARF 197 : SEGDES MLENTI 198 : ENDIF 199 : IF(MLREAC.NE.0)THEN 200 : MLENTI=MLREAC 201 : SEGDES MLENTI 202 : ENDIF 203 : IF(MLIMMO.NE.0)THEN 204 : MLENTI=MLIMMO 205 : SEGDES MLENTI 206 : ENDIF 207 : IF(JCHTMP.NE.0)THEN 208 : SEGDES ICHTMP 209 : ENDIF 210 : SEGDES MSOUPO,MPOVAL,MCHPOI 210 : CALL CHMDGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5) 211 : C 212 : C ON SAUVE LE RESULTAT 212 : CALL ECROBJ('CHPOINT',MCOACT) 213 : MSOUPO=MCOACT.IPCHP(1) 214 : SEGDES ICOACT,MCOACT,MSOUPO 215 : RETURN 216 : END 217 : 218 : 219 : 220 : 221 : 222 : 223 : 224 :
© Cast3M 2003 - All rights reserved.
Disclaimer