SUBROUTINE SCMR3(C0,C1,C2,C3,C4,C5,C6,C7,C8 1 ,NTYPES,SC,ESP,F,SOUR,VOL,NTYPH) SAVE FM2,FM4 DOUBLE PRECISION WRK,SUM COMMON /C6/ I,J,K,G,NI,NJ,NK,NG,IH,JH,KH,GH,NIH,NJH,NKH,NGH,LENA 1 ,J1,J2,J1H,J2H,MILYH,GD,GDH,GJH,JSM,NS,NSIDEH,NSIDRH,HEXAG 2 ,MAXI,ICOR(202),JCOR(202),KCOR(202) ,MAXNG 3 ,GCOR(201),NSC1(200),NSC2(200),NSC3(200),NSC1H(200),NSC2H(200) 4 ,NSC3H(200),NSC4H(200),OMEGA(200) 5 ,ISTAR,JSTAR,KSTAR,GSTAR,IEND,JEND,KEND,GEND,CYCLIC(8),SOURCE 6 ,EFF,NTHERH,NDOWNH,NUPH,NGHESP,NGHFIS 7 ,NSH,NSIDE,NSIDER,TITLE(20),JEOM,NOR,ADJOIN,NREB,NORM 8 ,NTCOFU,NTCOFN,NTCFH,NTCFNH,NTPHI,NTPHIS,NPHISH,NTPHIB,NTMESH 9 ,NTFIX2,NTFIXH,NGJ,NGJH,NGJK,NFJKH A ,NSJSM,NGJSM,NGJSOU,NSJH,NMGJH,NGJSOH,NGFIS,IS,NOTRHS LOGICAL ISTAR,JSTAR,KSTAR,GSTAR,IEND,JEND,KEND,GEND,CYCLIC 1 ,ADJOIN, HEXAG,SOURCE,NOTRHS INTEGER G,GD,GH,GDH,GJH,GCOR DIMENSION C0(NG,9),C1(NG,9),C2(NG,9),C3(NG,9),C4(NG,9) 1 ,C5(NG,9),C6(NG,9),C7(NG,9),C8(NG,9) 2 ,NTYPES(9),SC(9),ESP(NG,9),F(NG,9),SOUR(NG,9),VOL(9),NTYPH(9) DIMENSION LARH(2),C0H(9),C1H(9),C2H(9),C3H(9),C4H(9),C5H(9),C6H(9) 1 ,C7H(9),C8H(9),SCH(9),ESPH(9),FH(9),SOURH(9) 2 ,PHI(NG,9),PHIL(NG,9),PHIR(NG,9),PHIT(NG,9) 3 ,PHIB(NG,9) LOGICAL THREED IF (CYCLIC(3).AND.(NI.NE.NIH .OR. NJ.NE.NJH)) CALL ERROR('NO-1&') IF (CYCLIC(1)) CALL ERROR('CMR OF CYCLIC(1) NOT FULLY CODED&') KINDSC=1 IF (NGH.EQ.NG) KINDSC=0 IF (NGH.EQ.1) KINDSC=-1 JCLEAR=MILYH*NKH THREED=NK.GT.1 FM2=1. FM4=1. FN2=0. FN4=0. RETURN ENTRY CMR3(LARH,C0H,C1H,C2H,C3H,C4H,C5H,C6H,C7H,C8H 1 ,SCH,ESPH,FH,SOURH 2 ,PHI,PHIL,PHIR,PHIT,PHIB) IF (.NOT.ISTAR .OR. K.NE.1) GO TO 65 DO 63 G=1,JCLEAR 63 LARH(G)=0 G=1 DO 64 JUNK=1,NKH LARH(G)=999999 64 G=G+MILYH 65 J1H=MIN0(LARH(1),LCOR(J1,JCOR,NJH)) J2H=MAX0(LARH(2),LCOR(J2,JCOR,NJH)) LARH(1)=J1H LARH(2)=J2H IF (.NOT.ISTAR) GO TO 68 FM1=2./FLOAT(ICOR(IH+2)-ICOR(IH)) FM3=7654.321 IF (IH.GT.1) FM3=2./FLOAT(ICOR(IH+1)-ICOR(IH-1)) FN1=1.0-FM1 FN3=1.0-FM3 68 IF (.NOT.KSTAR) GO TO 70 FM7=7654.321 IF (KH.GT.1) FM7=2./FLOAT(KCOR(KH+1)-KCOR(KH-1)) FM8=2./FLOAT(KCOR(KH+2)-KCOR(KH)) FN7=1.0-FM7 FN8=1.0-FM8 70 CONTINUE JH=0 JEND=.TRUE. DO 200 J=1,J2 JSTAR=JEND IF (.NOT.JSTAR) GO TO 72 JH=JH+1 IF (CYCLIC(3)) GO TO 72 FM2=7654.321 IF (JH.GT.1) FM2=2./FLOAT(JCOR(JH+1)-JCOR(JH-1)) FM4=2./FLOAT(JCOR(JH+2)-JCOR(JH)) FN2=1.0-FM2 FN4=1.0-FM4 72 JEND=J.EQ.(JCOR(JH+1)-1) IF (J.LT.J1) GO TO 200 AF=VOL(J) JM1=J-1 JP1=J+1 IF (.NOT.CYCLIC(2)) GO TO 1 IF (J.EQ.J1) JM1=J2 IF (J.EQ.J2) JP1=J1 IF (J.EQ.J1) FM2=2./FLOAT(JCOR(NJH+2)-JCOR(NJH)) IF (J.EQ.J2) FM4=2./FLOAT(JCOR(NJH+2) - JCOR(NJH)) FN2=1.0-FM2 FN4=1.0-FM4 1 IF (.NOT.HEXAG) GO TO 75 FM5=2./(1./FM1 + 1./FM4) FM6=2./(1./FM2 + 1./FM3) FN5=1.0-FM5 FN6=1.0-FM6 FM5TAF=FM5*AF FM6TAF=FM6*AF 75 FM1TAF=FM1*AF FM2TAF=FM2*AF FM3TAF=FM3*AF FM4TAF=FM4*AF FM7TAF=FM7*AF FM8TAF=FM8*AF GH=0 GEND=.TRUE. GJH=NGH*(JH-1) LTYP=NTYPES(J)/NS IF (NGFIS.EQ.0) GO TO 79 TFISS=0. IF (F(1,LTYP).LT.0.) GO TO 79 DO 78 G=1,NG 78 TFISS=TFISS+F(G,LTYP)*PHI(G,J) TFISS=AF*TFISS 79 DO 100 G=1,NG GSTAR=GEND IF (.NOT.GSTAR) GO TO 2 GH=GH+1 GJH=GJH+1 2 GEND=G.EQ.(GCOR(GH+1)-1) WRK=C0(G,J) IF (WRK.EQ.1E20) GO TO 100 JUNK=J DO 144 N=1,NSIDE RUB=C1(G,JUNK) IF (RUB) 142,144,143 142 RUB=-RUB C1(G,JUNK)=0. 143 WRK=WRK+RUB 144 JUNK=JUNK+NJ WRK=WRK*PHI(G,J) DMP=C1(G,J)*PHIR(G,J) IF (IEND) GO TO 3 WRK=WRK-DMP GO TO 4 3 C1H(GJH)=C1H(GJH)+DMP*FM1TAF WRK =WRK -DMP*FN1 4 DMP=C2(G,J)*PHI(G,JM1) IF (JSTAR) GO TO 5 WRK=WRK-DMP GO TO 6 5 IF (CYCLIC(3) .AND. J.EQ.1) DMP=C2(G,J)*PHIR(G,J2+1) C2H(GJH)=C2H(GJH)+DMP*FM2TAF WRK =WRK -DMP*FN2 6 DMP=C3(G,J)*PHIL(G,J) 100 CONTINUE 200 CONTINUE RETURN END