SUBROUTINE WRITESCA(MXNX,MXNY,MXNZ,NX,NY,NZ,DX,ICOMP, & IXYZ0,MXNAT,MXN3,NAT,NAT3,WAVEA,MXWAV,NWAV, & AEFFA,MXRAD,NRAD,ITHETA,IBETA,IPHI,THETA, & MXTHET,NTHETA,BETA,MXBETA,NBETA,PHI,MXPHI, & NPHI,NSMELTS,TIMERS,MXTIMERS,NTIMERS, & CBINFILE,IOBIN,CBINFLAG,CNETFILE,IDNC, & CNETFLAG,ILIN10,ILIN12,IORI,IWRKSC,IORTH, & IRAD,IWAV,MXCOMP,MXSCA,NAT0,NAVG,ITNUM, & MXITER,NCOMP,NORI,NSCAT,CALPHA,CDESCR,CFLAVG, & CFLSCA,CMDFFT,CMDTRQ,CSHAPE,CSTAMP,AEFF,AK1, & AKR,BETAD,BETMID,BETMXD,ETASCA,PHID,PHIMID, & PHIMXD,THETAD,THTMID,THTMXD,TOL,WAVE,XX,A1, & A2,PHIN,QABS,QABSUM,QBKSCA,QBKSUM,QEXSUM, & QEXT,QPHA,QPHSUM,QSCAG,QSCAG2,QSCAT,QSCGSUM, & QSCG2SUM,QSCSUM,QTRQAB,QTRQABSUM,QTRQSC, & QTRQSCSUM,S1111,S2121,SM,SMIND1,SMIND2,SMORI, & THETAN,CX1121,CXE01,CXE01R,CXE02,CXE02R, & CXEPS,CXRFR,CXF11,CXF21,CXF12,CXF22) C IMPLICIT NONE C C Scalar Arguments .. C REAL AEFF,AK1,BETAD,BETMID,BETMXD,ETASCA,PHID,PHIMID,PHIMXD, & THETAD,THTMID,THTMXD,TOL,WAVE,XX INTEGER IBETA,IDNC,ILIN10,ILIN12,IOBIN,IORI,IORTH,IPHI, & IRAD,ITHETA,IWAV,IWRKSC,MXBETA,MXCOMP,MXITER,MXN3,MXNAT, & MXNX,MXNY,MXNZ,MXPHI,MXRAD,MXSCA,MXTHET,MXTIMERS,MXWAV, & NAT,NAT0,NAT3,NAVG,NBETA,NCOMP,NORI,NPHI,NRAD,NSCAT, & NSMELTS,NTHETA,NTIMERS,NWAV,NX,NY,NZ INTEGER ITNUM(2) CHARACTER CALPHA*6,CBINFLAG*6,CMDFFT*6,CMDTRQ*6,CNETFLAG*6, & CSHAPE*6,CFLAVG*13,CBINFILE*14,CFLSCA*14,CNETFILE*14, & CSTAMP*22,CDESCR*67 C C Array Arguments .. C COMPLEX CX1121(MXSCA),CXE01(3),CXE01R(3),CXE02(3),CXE02R(3), & CXEPS(MXCOMP),CXF11(MXSCA),CXF12(MXSCA),CXF21(MXSCA), & CXF22(MXSCA),CXRFR(MXCOMP) REAL A1(3),A2(3),AEFFA(MXRAD),AKR(3),BETA(MXBETA),DX(3), & PHI(MXPHI),PHIN(MXSCA),QABS(2), & QABSUM(2),QBKSCA(2),QBKSUM(2),QEXSUM(2),QEXT(2),QPHA(2), & QPHSUM(2),QSCAG(3,2),QSCAG2(2),QSCAT(2),QSCG2SUM(2), & QSCGSUM(3,2),QSCSUM(2),QTRQAB(3,2),QTRQABSUM(3,2), & QTRQSC(3,2),QTRQSCSUM(3,2), & S1111(MXSCA),S2121(MXSCA),SM(MXSCA,4,4),SMORI(MXSCA,4,4), & THETA(MXTHET),THETAN(MXSCA),TIMERS(MXTIMERS),WAVEA(MXWAV) INTEGER*2 ICOMP(MXN3),IXYZ0(MXNAT,3) INTEGER SMIND1(9),SMIND2(9) C Local variables: COMPLEX CXVAR1 REAL DEGRAD,MKD,PHIND,PI,PPOL,RVAR1,RVAR2,RVAR3,THETND INTEGER I,J,ND REAL G(2),G2(2),QAV(18) C External Subroutines: EXTERNAL NAMER,WRITEBIN,WRITENET C Intrinsic Functions: INTRINSIC CONJG,SQRT C Save statement: SAVE DEGRAD C Data statements .. DATA DEGRAD/57.29578/ C*********************************************************************** C C Purpose of this module is to collect a lot of the output code into C a single module. C C If IORI = 0, then print orientational average C If IORI > 0, print output for specific orientation C C History: C 96.11.14 (PJF) added binary write options (see also info in C "versions.f" about IDL postprocessing) C possible "checkpointing" could be done here "close(iobin)" C open(iobin,file=cbinfile,form='unformatted',access='append') C (which is non-standard Fortran 77 (but standard in F90) C open(iobin,file=cbinfile,form='unformatted',status='old') C 96.11.21 (BTD) added call to WRITENET if called with CNETFLAG='NCCLOS' C in order to get call to NCCLOS out of DDSCAT.f C 98.01.11 (BTD) added DX(3) to argument list to pass information on C nonuniform lattice spacing [development of DDSCAT.6.0] C 98.11.16 (BTD) corrected CX01R -> CXE01R in argument list of WRITEBIN C 98.12.12 (BTD) Introduce NSMELTS,SMIND1,SMIND2 to argument list to C allow selection of Muller matrix elements to be C printed out. Add code to allow from 1 to 9 matrix C elements to be printed. C 98.12.13 (BTD) Modify to print out validity criterion |m|kd C for each composition C 03.01.30 (BTD) disabled output line to print out dx,dy,dz C 03.02.13 (BTD) added one more digit of precision to output Q values C with appropriate modifications to format statements C 03.04.14 (BTD) added ITNUM(2) and MXITER to argument list C added ITNUM(2) = number of iterations C and MXITER = max number of iterations allowed C to output statements 9150 and 9155 C 03.09.01 (BTD) cosmetic change to output statement: g -> g(1) C 03.10.23 (BTD) removed ICTHM and IPHIM from argument list c removed ICTHM and IPHIM from argument list of c WRITENET and WRITEBIN c removed ICTHM and IPHIM from WRITE(..,9033) c added NAVG to argument list c added NAVG to WRITE(..,9033) c added NAVG to argument list of WRITENET and WRITEBIN c write NAVG to qtable,wxxrxxkxxx.sca, wxxrxxori.avg C 04.02.22 (BTD) added IWRKSC to argument list of WRITESCA and use to c control writing to ascii output files c 04.05.21 (BTD) reordered QSCGSUM and QSCG2SUM in argument list c 04.12.29 (BTD) corrected error in writing Mueller matrix for the c "sca" files when IWRKSC=1 C end history C C Copyright (C) 1996,1998,2003,2004 C B.T. Draine and P.J. Flatau C This code is covered by the GNU General Public License. C*********************************************************************** C If CNETFLAG = 'NCCLOS' then call WRITENET to close netCDF files IF(CNETFLAG.EQ.'NCCLOS')THEN CALL WRITENET(CNETFILE,IDNC,CNETFLAG,CSTAMP,CDESCR,CMDFFT, & CALPHA,CSHAPE,CMDTRQ,MXWAV,MXRAD,MXTHET, & MXBETA,MXPHI,MXN3,MXNAT,MXSCA,MXTIMERS,IORTH, & NX,NY,NZ,NAT0,NAT,NAT3,NAVG,NSCAT,NCOMP,NORI, & NWAV,NRAD,NTHETA,NPHI,NBETA,NTIMERS,MXNX,MXNY, & MXNZ,MXCOMP,BETMID,BETMXD,THTMID,THTMXD, & PHIMID,PHIMXD,TOL,DX,WAVEA,AEFFA, & THETA,BETA,PHI,A1,A2,ICOMP,IXYZ0,IWAV,IRAD, & ITHETA,IBETA,IPHI,IORI,AEFF,WAVE,XX,AK1,BETAD, & THETAD,PHID,AKR,CXE01R,CXE02R,CXRFR,CXEPS, & QEXT,QABS,QSCAT,G,QBKSCA,QPHA,QAV,QTRQAB, & QTRQSC,SM,SMORI, c btd 04.02.22 add next two lines & QEXSUM,QABSUM,QSCSUM,QBKSUM,QPHSUM,QSCGSUM, & QTRQABSUM,QTRQSCSUM, c --------------- & PHIN,THETAN,TIMERS) RETURN ENDIF C If IORI > 0, then write out scattering properties for this specific C target orientation. PI=4.*ATAN(1.) IF(IORI.GT.0)THEN C*** Compute G= and G2= DO J=1,IORTH G(J)=QSCAG(1,J)/QSCAT(J) G2(J)=QSCAG2(J)/QSCAT(J) ENDDO IF(IWRKSC.EQ.1)THEN CALL NAMER(IWAV,IRAD,IORI,CFLSCA,CFLAVG) OPEN(UNIT=8,FILE=CFLSCA,STATUS='UNKNOWN') WRITE(8,FMT=9030)CSTAMP,CDESCR,CMDFFT,CALPHA,CSHAPE,NAT0 C following code to be enabled for noncubic treatment: C & ,DX WRITE(8,FMT=9032)AEFF,WAVE,XX DO J=1,NCOMP MKD=(4.*PI/(3.*NAT0))**(1./3.)* & SQRT(REAL(CXRFR(J)*CONJG(CXRFR(J))))*XX WRITE(8,FMT=9031)CXRFR(J),CXEPS(J),MKD,J ENDDO WRITE(8,FMT=9033)TOL,NAVG,A1,A2 WRITE(8,FMT=9035)AKR,CXE01R,CXE02R WRITE(8,FMT=9040)BETAD,THETAD,PHID,ETASCA WRITE(8,FMT=9050)QEXT(1),QABS(1),QSCAT(1),G(1),G2(1), & QBKSCA(1),QPHA(1) ENDIF IF(IORTH.EQ.1)THEN C Assign "missing value" value if there is only one polarization DO I=1,18 QAV(I)=-999. ENDDO QEXT(2)=-999. QABS(2)=-999. QSCAT(2)=-999. QBKSCA(2)=-999. QPHA(2)=-999. G(2)=-999. G2(2)=-999. DO J=1,3 QSCAG(J,2)=-999. ENDDO QSCAG2(2)=-999. ENDIF IF(IORTH.EQ.2)THEN QAV(1)=.5*(QEXT(1)+QEXT(2)) QAV(2)=.5*(QABS(1)+QABS(2)) QAV(3)=.5*(QSCAT(1)+QSCAT(2)) QAV(4)=.5*(QSCAG(1,1)+QSCAG(1,2))/QAV(3) QAV(5)=.5*(QSCAG2(1)+QSCAG2(2))/QAV(3) QAV(6)=.5*(QBKSCA(1)+QBKSCA(2)) QAV(7)=.5*(QPHA(1)+QPHA(2)) QAV(8)=QEXT(1)-QEXT(2) QAV(9)=QPHA(1)-QPHA(2) DO J=1,3 QAV(9+J)=.5*(QSCAG(J,1)+QSCAG(J,2)) ENDDO IF(CMDTRQ.EQ.'DOTORQ')THEN DO J=1,3 QAV(12+J)=.5*(QTRQAB(J,1)+QTRQAB(J,2)) QAV(15+J)=.5*(QTRQSC(J,1)+QTRQSC(J,2)) ENDDO ENDIF IF(IWRKSC.EQ.1)WRITE(8,FMT=9055)QEXT(2),QABS(2),QSCAT(2), & G(2),G2(2),QBKSCA(2),QPHA(2),(QAV(J),J=1,9) ENDIF IF(IWRKSC.EQ.1)THEN WRITE(8,FMT=9150)(QSCAG(J,1),J=1,3),ITNUM(1),MXITER,NAVG IF(IORTH.EQ.2)THEN WRITE(8,FMT=9155)(QSCAG(J,2),J=1,3),ITNUM(2),MXITER,NAVG, & (QAV(J),J=10,12) ENDIF ENDIF IF(CMDTRQ.EQ.'DOTORQ')THEN IF(IWRKSC.EQ.1)THEN WRITE(8,FMT=9250)(QTRQAB(J,1),J=1,3),(QTRQSC(J,1),J=1,3) IF(IORTH.EQ.2)WRITE(8,FMT=9255)(QTRQAB(J,2),J=1,3), & (QTRQSC(J,2),J=1,3),(QAV(J),J=13,18) ENDIF ELSE C add missing value code (set to -999.) DO I=1,3 DO J=1,2 QTRQAB(I,J)=-999. QTRQSC(I,J)=-999. ENDDO ENDDO ENDIF IF(IORTH.EQ.1)THEN IF(IWRKSC.EQ.1)WRITE(8,FMT=9060) DO ND=1,NSCAT C convert scattering angles to degrees PHIND=DEGRAD*PHIN(ND) THETND=DEGRAD*THETAN(ND) RVAR1=REAL(CONJG(CXF11(ND))*CXF11(ND)) RVAR2=REAL(CONJG(CXF21(ND))*CXF21(ND)) CXVAR1=CONJG(CXF11(ND))*CXF21(ND) IF(IWRKSC.EQ.1) & WRITE(8,FMT=9070)ND,THETND,PHIND,RVAR1,RVAR2,CXVAR1 ENDDO ELSEIF(IORTH.EQ.2)THEN IF(IWRKSC.EQ.1)THEN WRITE(8,FMT=9080) IF(NSMELTS.EQ.1)THEN WRITE(8,FMT=9081)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.2)THEN WRITE(8,FMT=9082)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.3)THEN WRITE(8,FMT=9083)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.4)THEN WRITE(8,FMT=9084)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.5)THEN WRITE(8,FMT=9085)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.6)THEN WRITE(8,FMT=9086)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.7)THEN WRITE(8,FMT=9087)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.8)THEN WRITE(8,FMT=9088)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.9)THEN WRITE(8,FMT=9089)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ENDIF DO ND=1,NSCAT C convert scattering angles to degrees PHIND=DEGRAD*PHIN(ND) THETND=DEGRAD*THETAN(ND) C Compute PPOL = degree of linear polarization of scattered light C for incident unpolarized light PPOL=SQRT(SM(ND,2,1)**2+SM(ND,3,1)**2)/SM(ND,1,1) WRITE(8,FMT=9090)THETND,PHIND,PPOL, c*** c 04.12.29 (BTD) correction c & (SMORI(ND,SMIND1(J),SMIND2(J)),J=1,NSMELTS) & (SM(ND,SMIND1(J),SMIND2(J)),J=1,NSMELTS) c*** ENDDO ENDIF ENDIF IF(IWRKSC.EQ.1)CLOSE(8) ELSE C This module writes out results from orientational averaging. C (arrive here when called with IORI=0) OPEN(UNIT=8,FILE=CFLAVG,STATUS='UNKNOWN') WRITE(8,FMT=9030)CSTAMP,CDESCR,CMDFFT,CALPHA,CSHAPE,NAT0 C following code to be enabled for noncubic treatment: C WRITE(8,FMT=9030)CSTAMP,CDESCR,CMDFFT,CALPHA,CSHAPE,NAT0,DX WRITE(8,FMT=9032)AEFF,WAVE,XX DO J=1,NCOMP MKD=(4.*PI/(3.*NAT0))**(1./3.)* & SQRT(REAL(CXRFR(J)*CONJG(CXRFR(J))))*XX WRITE(8,FMT=9031)CXRFR(J),CXEPS(J),MKD,J ENDDO WRITE(8,FMT=9033)TOL,NAVG,A1,A2 RVAR1=AK1 RVAR2=0. RVAR3=0. WRITE(8,FMT=9037)RVAR1,RVAR2,RVAR3,CXE01,CXE02 WRITE(8,FMT=9042)BETMID,BETMXD,NBETA,THTMID,THTMXD,NTHETA, & PHIMID,PHIMXD,NPHI,ETASCA,NORI,IORTH RVAR1=QSCGSUM(1,1)/QSCSUM(1) RVAR2=QSCG2SUM(1)/QSCSUM(1) WRITE(8,FMT=9050)QEXSUM(1),QABSUM(1),QSCSUM(1),RVAR1,RVAR2, & QBKSUM(1),QPHSUM(1) IF(IORTH.EQ.1)THEN WRITE(8,FMT=9150)(QSCGSUM(J,1),J=1,3) IF(CMDTRQ.EQ.'DOTORQ')WRITE(8,FMT=9250) & (QTRQABSUM(J,1),J=1,3),(QTRQSCSUM(J,1),J=1,3) WRITE(8,FMT=9060) DO ND=1,NSCAT C Convert scattering angles to degrees PHIND=DEGRAD*PHIN(ND) THETND=DEGRAD*THETAN(ND) WRITE(8,FMT=9070)ND,THETND,PHIND,S1111(ND),S2121(ND), & CX1121(ND) ENDDO C Write orientationally-averaged Q values (except Qpha) to 'qtable': OPEN(UNIT=10,FILE='qtable',STATUS='OLD') DO ND=1,ILIN10 READ(10,FMT=*) ENDDO RVAR1=QSCGSUM(1,1)/QSCSUM(1) RVAR2=QSCG2SUM(1)/QSCSUM(1) WRITE(10,FMT=9056)AEFF,WAVE,QEXSUM(1),QABSUM(1),QSCSUM(1), & RVAR1,RVAR2,QBKSUM(1),NAVG ILIN10=ILIN10+1 CLOSE(10) OPEN(UNIT=12,FILE='qtable2',STATUS='OLD') DO ND=1,ILIN12 READ(12,FMT=*) ENDDO WRITE(12,FMT=9057)AEFF,WAVE,QPHSUM(1) ILIN12=ILIN12+1 CLOSE(12) ELSEIF(IORTH.EQ.2)THEN RVAR1=QSCGSUM(1,2)/QSCSUM(2) RVAR2=QSCG2SUM(2)/QSCSUM(2) QAV(1)=.5*(QEXSUM(1)+QEXSUM(2)) QAV(2)=.5*(QABSUM(1)+QABSUM(2)) QAV(3)=.5*(QSCSUM(1)+QSCSUM(2)) QAV(4)=.5*(QSCGSUM(1,1)+QSCGSUM(1,2))/QAV(3) QAV(5)=.5*(QSCG2SUM(1)+QSCG2SUM(2))/QAV(3) QAV(6)=.5*(QBKSUM(1)+QBKSUM(2)) QAV(7)=.5*(QPHSUM(1)+QPHSUM(2)) QAV(8)=QEXSUM(1)-QEXSUM(2) QAV(9)=QPHSUM(1)-QPHSUM(2) DO J=1,3 QAV(9+J)=.5*(QSCGSUM(J,1)+QSCGSUM(J,2)) ENDDO IF(CMDTRQ.EQ.'DOTORQ')THEN DO J=1,3 QAV(12+J)=.5*(QTRQABSUM(J,1)+QTRQABSUM(J,2)) QAV(15+J)=.5*(QTRQSCSUM(J,1)+QTRQSCSUM(J,2)) ENDDO ENDIF RVAR2=.5*(QSCG2SUM(1)+QSCG2SUM(2))/QAV(3) WRITE(8,FMT=9055)QEXSUM(2),QABSUM(2),QSCSUM(2),RVAR1,RVAR2, & QBKSUM(2),QPHSUM(2),(QAV(J),J=1,9) WRITE(8,FMT=9150)(QSCGSUM(J,1),J=1,3),ITNUM(1),MXITER,NAVG WRITE(8,FMT=9155)(QSCGSUM(J,2),J=1,3),ITNUM(2),MXITER,NAVG, & (QAV(J),J=10,12) IF(CMDTRQ.EQ.'DOTORQ')THEN WRITE(8,FMT=9250)(QTRQABSUM(J,1),J=1,3), & (QTRQSCSUM(J,1),J=1,3) WRITE(8,FMT=9255)(QTRQABSUM(J,2),J=1,3), & (QTRQSCSUM(J,2),J=1,3),(QAV(J),J=13,18) ENDIF C Write orientationally-averaged Q values (except Qpha) to 'qtable': OPEN(UNIT=10,FILE='qtable',STATUS='OLD') DO ND=1,ILIN10 READ(10,FMT=*) ENDDO WRITE(10,FMT=9056)AEFF,WAVE,QAV(1),QAV(2),QAV(3),QAV(4), & QAV(5),QAV(6),NAVG ILIN10=ILIN10+1 CLOSE(10) OPEN(UNIT=12,FILE='qtable2',STATUS='OLD') DO ND=1,ILIN12 READ(12,FMT=*) ENDDO WRITE(12,FMT=9057)AEFF,WAVE,QAV(7),QAV(8),QAV(9) ILIN12=ILIN12+1 CLOSE(12) C WRITE(8,FMT=9080) IF(NSMELTS.EQ.1)THEN WRITE(8,FMT=9081)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.2)THEN WRITE(8,FMT=9082)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.3)THEN WRITE(8,FMT=9083)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.4)THEN WRITE(8,FMT=9084)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.5)THEN WRITE(8,FMT=9085)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.6)THEN WRITE(8,FMT=9086)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.7)THEN WRITE(8,FMT=9087)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.8)THEN WRITE(8,FMT=9088)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ELSEIF(NSMELTS.EQ.9)THEN WRITE(8,FMT=9089)(SMIND1(J),SMIND2(J),J=1,NSMELTS) ENDIF DO ND=1,NSCAT C Convert scattering angles to degrees PHIND=DEGRAD*PHIN(ND) THETND=DEGRAD*THETAN(ND) C Compute PPOL = degree of linear polarization of scattered light C for incident unpolarized light (Bohren & Huffman p. 382) PPOL=SQRT(SMORI(ND,2,1)**2+SMORI(ND,3,1)**2)/ & SMORI(ND,1,1) WRITE(8,FMT=9090)THETND,PHIND,PPOL, & (SMORI(ND,SMIND1(J),SMIND2(J)),J=1,NSMELTS) ENDDO ENDIF CLOSE(8) ENDIF C write FORTRAN unformatted file IF(CBINFLAG.NE.'NOTBIN')THEN CALL WRITEBIN(CBINFLAG,CBINFILE,IOBIN,CSTAMP,CDESCR,CMDFFT, & CALPHA,CSHAPE,CMDTRQ,MXWAV,MXRAD,MXTHET, & MXBETA,MXPHI,MXN3,MXNAT,MXSCA,MXTIMERS,IORTH, & NX,NY,NZ,NAT0,NAT,NAT3,NAVG,NSCAT,NCOMP,NORI, & NWAV,NRAD,NTHETA,NPHI,NBETA,NTIMERS,MXNX,MXNY, & MXNZ,MXCOMP,BETMID,BETMXD,THTMID,THTMXD, & PHIMID,PHIMXD,TOL,DX,WAVEA,AEFFA, & THETA,BETA,PHI,A1,A2,ICOMP,IXYZ0,IWAV,IRAD, & IORI,AEFF,WAVE,XX,AK1,BETAD,THETAD,PHID,AKR, & CXE01R,CXE02R,CXRFR,CXEPS,QEXT,QABS,QSCAT,G, & QBKSCA,QPHA,QAV,QTRQAB,QTRQSC,SM,PHIN,THETAN, & TIMERS) ENDIF c btd 04.02.22 change c add following to WRITENET argument list: c QEXSUM c QABSUM c QSCSUM c QBKSUM c QPHSUM c QSCGSUM c QTRQABSUM c QTRQSCSUM IF(CNETFLAG.NE.'NOTCDF')THEN CALL WRITENET(CNETFILE,IDNC,CNETFLAG,CSTAMP,CDESCR,CMDFFT, & CALPHA,CSHAPE,CMDTRQ,MXWAV,MXRAD,MXTHET, & MXBETA,MXPHI,MXN3,MXNAT,MXSCA,MXTIMERS,IORTH, & NX,NY,NZ,NAT0,NAT,NAT3,NAVG,NSCAT,NCOMP,NORI, & NWAV,NRAD,NTHETA,NPHI,NBETA,NTIMERS,MXNX,MXNY, & MXNZ,MXCOMP,BETMID,BETMXD,THTMID,THTMXD, & PHIMID,PHIMXD,TOL,DX,WAVEA,AEFFA, & THETA,BETA,PHI,A1,A2,ICOMP,IXYZ0,IWAV,IRAD, & ITHETA,IBETA,IPHI,IORI,AEFF,WAVE,XX,AK1,BETAD, & THETAD,PHID,AKR,CXE01R,CXE02R,CXRFR,CXEPS, & QEXT,QABS,QSCAT,G,QBKSCA,QPHA,QAV,QTRQAB, & QTRQSC,SM,SMORI, c btd 04.02.22 add next two lines & QEXSUM,QABSUM,QSCSUM,QBKSUM,QPHSUM,QSCGSUM, & QTRQABSUM,QTRQSCSUM, c-------------------------------- & PHIN,THETAN,TIMERS) ENDIF RETURN 9030 FORMAT(' DDSCAT --- ',A,/,' TARGET ---',A,/,' ',A, & ' --- method of solution ',/,' ',A, & ' --- prescription for polarizabilies',/,' ',A, & ' --- shape ',/,I7,' = NAT0 = number of dipoles') c following code to be enabled for noncubic treatment c 9030 FORMAT(' DDSCAT --- ',A,/,' TARGET ---',A,/,' ',A, c & ' --- method of solution ',/,' ',A, c & ' --- prescription for polarizabilies',/,' ',A, c & ' --- shape ',/,I7,' = NAT0 = number of dipoles', C & 3F8.5,' = normalized lattice spacings dx,dy,dz') 9031 FORMAT('n= (',F7.4,' , ',F7.4,'), eps.= (',F8.4,' , ',F7.4, & ') |m|kd=',0PF8.4,' for subs.',I2) 9032 FORMAT(' AEFF=',F10.5,' =',' effective radius (physical units)', & /,' WAVE=',F10.5,' = wavelength (physical units)',/, & 'K*AEFF=',F10.5,' = 2*pi*aeff/lambda') 9033 FORMAT(' TOL=',1P,E10.3,' = error tolerance for CCG method',/, & ' NAVG=',I6, & ' = (theta,phi) values used in comp. of Qsca,g',/, & 0P,'(',F8.5,2F9.5,') = target axis A1 in Target Frame',/, & 1X,'(',F8.5,2F9.5,') = target axis A2 in Target Frame') 9035 FORMAT(1X,'(',F8.5,2F9.5,') = k vector (latt. units) in TF',/,1X, & 3 ('(',F8.5,',',F8.5,')'),'=inc.pol.vec. 1 in TF',/,1X, & 3 ('(',F8.5,',',F8.5,')'),'=inc.pol.vec. 2 in TF') 9037 FORMAT(1X,'(',F8.5,2F9.5, & ') = k vector (latt. units) in Lab Frame',/,1X, & 3 ('(',F8.5,',',F8.5,')'),'=inc.pol.vec. 1 in LF',/,1X, & 3 ('(',F8.5,',',F8.5,')'),'=inc.pol.vec. 2 in LF') 9040 FORMAT(' BETA =',F7.3,' = rotation of target around A1',/, & ' THETA=',F7.3,' = angle between A1 and k',/,' PHI =', & F7.3,' = rotation of A1 around k',/, & F7.4,' = ETASCA = param. controlling # of ', & 'scatt. dirs used to calculate etc.') 9042 FORMAT(2F8.3,' = beta_min, beta_max ; NBETA =',I2,/,2F8.3, & ' = theta_min, theta_max; NTHETA=',I2,/,2F8.3, & ' = phi_min, phi_max ; NPHI =',I2,/, & F7.4,' = ETASCA = param. controlling # of ', & 'scatt. dirs used to calculate etc.',/, & ' Results averaged over ',I3,' target orientations',/, & ' and ',I3,' incident polarizations') 9050 FORMAT(10X,'Qext',7X,'Qabs',7X,'Qsca',6X,'g(1)=',2X, & '',5X,'Qbk',7X, & 'Qpha',/,1X,'JO=1: ',1P,3E11.4,E12.4,2E11.4,E12.4) 9055 FORMAT(1X,'JO=2: ',1P,3E11.4,E12.4,2E11.4,E12.4,/,1X,'mean: ', & 3E11.4,E12.4,2E11.4,E12.4,/,1X,'Qpol= ',E11.4,50X,'dQpha=', & E12.4) 9056 FORMAT(1P,E10.4,4E11.4,E12.4,E11.4,E11.4,I6) 9057 FORMAT(1P,E10.4,E11.4,3E12.4) 9060 FORMAT('**** Selected scattering directions ', & ' [note: incident pol state 1 is FIXED!]',/, & ' ND THETA PHI <|f11|^2> <|f21|^2> Re', & ' Im') 9070 FORMAT(I3,2F6.1,1P,2E10.3,2E11.3) C 9080 FORMAT(' ***************** Selected scattering directions *****', C & '************',/, C & ' ND THETA PHI <|f11|^2> <|f21|^2> <|f12|^2> ', C & '<|f22|^2> DEPOLR PPOL') 9080 FORMAT(12X,'** Mueller matrix elements for selected scattering ', & 'directions **') 9081 FORMAT('theta phi Pol. S_',I1,I1) 9082 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1) 9083 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1) 9084 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1) 9085 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1) 9086 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1) 9087 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1) 9088 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1) 9089 FORMAT('theta phi Pol. S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1,7X, & 'S_',I1,I1,7X,'S_',I1,I1,7X,'S_',I1,I1) 9090 FORMAT(F5.1,F6.1,F9.5,1P,9E11.3) 9150 FORMAT(9X,'Qsca*g(1) Qsca*g(2) Qsca*g(3) iter mxiter', & 2X,'Nsca'/, & 1X,'JO=1:',1P,3E12.4,3I7) 9155 FORMAT(1X,'JO=2:',1P,3E12.4,3I7,/,1X,'mean:',1P,3E12.4) 9250 FORMAT(8X,'Qtrqab(1) Qtrqab(2) Qtrqab(3) ', & 'Qtrqsc(1) Qtrqsc(2) Qtrqsc(3)',/,1X,'JO=1:',1P,6E11.3) 9255 FORMAT(1X,'JO=2:',1P,6E11.3,/,1X,'mean:',1P,6E11.3) END