	subroutine makefile(ch)
C
C	THIS IS MAKEFILE39, DERIVED FROM MAKEFILE12
C
C	A PROGRAM TO SEARCH FOR LARGE AMPLITUDE WHISTLERS IN MAGSPHERE IN TDSF.
C		OR FILL
C
C	OUTPUT IN MAKEFILE39.RESULTS, SET IN MISSION_SCAN39 AS UNIT 90
C
C	INSIDE TIMES:
C		2000 APR 21 TO AUG 23 APPROX, PETAL ORBITS
C
C	CRITERIA:  LARGE AMPLITUDE, AVERAGE FREQENCY LESS THAT 5 KHZ,
C		VMATRIX HAS RATIO OF EIGENVALUES LARGER THAN SOME LIMIT
C		TO EXCLUDE ION ACOUSTIC WAVES AND OTHER LINEAR POLARIZATION
C		WIND INSIDE OF 10 RE
C
	integer*4 ch,ok,okt,OK1,OK2,SCETI4(2),N1DATA(2048),N2DATA(2048)
	INTEGER*4 W_CHANNEL_CLOSE,W_EVENT,RET_SIZE,W_MESSAGES_OFF
	INTEGER*4 W_ITEM_I4,W_ITEM_R4,W_ITEM_R8
	INTEGER*4 TDS_CHANNEL,ISRC,SUNCLOCK,ERT(2),ERTDAY
	REAL*8 SCET8,XGSE,YGSE,ZGSE,RGSE
	REAL DBSPEC1(1025),V1DATA(2048)
	REAL DBSPEC2(1025),V2DATA(2048)
	REAL ZCROSS(1024),Z1INT(1024),Z2INT(1024)
	REAL FREQ(1024),FCOUNT(2),FAVR(2),FSTD(2),F3MOM(2),FBW(2),SKEW(2)
	character*32 ITEM
	character*4 event
	DATA TWOPI /6.2831853/
	DATA YXRATIO /11.8/
C	ABOVE BASED ON LEFFX = 41.1, LEFFY = 3.79
	DATA PXTOT,PYTOT /0.,0./
	data event /'TDSF'/
C	data event /'FILL'/
C
        COMMON /VARMATX/ EVAL(2),EVECT(2,2)
        REAL DATA(2050,4)
        REAL WT(2048)
C
	YXSQ = YXRATIO**2
	IFOUND = 0
	NEVTCNT = 0
 100	ok = w_event(ch,event)
	NEVTCNT = NEVTCNT+1
C
C	CHECK FOR END OF RECORD
C
	if (ok.ne.1) then
		if(ok.eq.82) then
		   ok = w_channel_close(ch)
		   return
	        endif
		write(6,*) 'cannot open ',event, ', ok=', ok
	endif
C
C	END OF END OF RECORD CHECK
C
	OKT = W_MESSAGES_OFF(ch)
C
	ITEM = 'CHANNEL'
	ok = W_ITEM_I4(ch, item, TDS_CHANNEL, 1, ret_size)
C
C	IPROS = 2
	IPROX = 4
	IF(TDS_CHANNEL.EQ.1) THEN
C	  ITEM = 'DATA'
C	  ok1 = W_ITEM_I4(ch, item, N1DATA, 2048, ret_size)
	  CALL TDS_PHYS(CH,IPROS,N1DATA,V1DATA,DBSPEC1)
	  ITEM = 'EVENT_NUMBER'
	  ok = W_ITEM_I4(ch, item, NO_EVT1, 1, ret_size)
		MAXCH1 = 0
	 	V1MAX = 0.
		DO N = 1,2048
		  MAXCH1 = MAX0(MAXCH1,IABS(N1DATA(N)-128))
		  V1MAX = AMAX1(V1MAX,ABS(V1DATA(N)))
		ENDDO
	  GO TO 100
	ELSEIF(TDS_CHANNEL.EQ.2) THEN
C	  ITEM = 'DATA'
C	  ok2 = W_ITEM_I4(ch, item, N2DATA, 2048, ret_size)
	  CALL TDS_PHYS(CH,IPROS,N2DATA,V2DATA,DBSPEC2)
	  ITEM = 'EVENT_NUMBER'
	  ok = W_ITEM_I4(ch, item, NO_EVT, 1, ret_size)
	  IF(NO_EVT.NE.NO_EVT1) GO TO 100
		MAXCH2 = 0
		V2MAX = 0.
		DO N = 1,2048
		  MAXCH2 = MAX0(MAXCH2,IABS(N2DATA(N)-128))
		  V2MAX =  AMAX1(V2MAX,ABS(V2DATA(N)))
		ENDDO
	ELSE
	  GO TO 100
	ENDIF
C*****
C	IF(MAXCH1.LT.107.AND.MAXCH2.LT.90) PRINT*,'MAXCH SMALL',V1MAX,V2MAX
C	IF(MAXCH1.LT.107.AND.MAXCH2.LT.90) GO TO 100
C*****
C
C	MOST OF THE EVENTS ARE BLOBS.  TO ELIMINATE THEM:
C	BLOBS START NEAR THE MIDDLE, AND MOSTLY OCCUPY THE
C	SECOND HALF OF AN EVENT.  SO REQUIRE THAT THE MAXIMUM
C	INTERVAL BETWEEN ZEROS IN THE SECOND HALF NOT BE
C	MORE THAN ?? TIMES THE AVERAGE INTERVAL IN THE FIRST
C	HALF
C
C	THERE ARE ALSO SPIKES.  TO ELIMINATE THEM, CALCULATE THE
C	NUMBER OF POINTS WHICH ARE LARGER THAN HALF THE PEAK.
C
	IF(TDS_CHANNEL.EQ.1) GO TO 100		! GO GET CHANNEL 2
	IF(TDS_CHANNEL.NE.2) GO TO 100
C
C	REQUIRE AT LEAST 10 MV/M IN BOTH CHANNELS.  THIS TURNED OUT TO BE
C	TOO STRINGENT, AS EIGENVALUES ARE AVERAGED, SO I CHANGED IT TO 4 MV/M
C
	E1MAX = V1MAX/41.1
	E2MAX = V2MAX/3.79
C	PRINT*,'EVENT NO ',NO_EVT
C	IF(E1MAX.LT..004.OR.E2MAX.LT..004) print*,'E1,E2MAX,SMALL',E1MAX,E2MAX
	IF(E1MAX.LT..01.OR.E2MAX.LT..01) GO TO 100
C
	ITEM = 'WIND_ORBIT_X(GSE)_R8'
	ok = W_ITEM_R8(ch, item, XGSE, 1, ret_size)
	ITEM = 'WIND_ORBIT_Y(GSE)_R8'
	ok = W_ITEM_R8(ch, item, YGSE, 1, ret_size)
	ITEM = 'WIND_ORBIT_Z(GSE)_R8'
	ok = W_ITEM_R8(ch, item, ZGSE, 1, ret_size)
	RGSE = DSQRT(XGSE**2+YGSE**2+ZGSE**2)
C
	IF(RGSE.GT.2.5D05) THEN			! LIMIT 40 RE
C	    ADVANCE BY ONE DAY AND GET ANOTHER EVENT
C	    ITEM = 'EVENT_SCET_R8'
C	    OK = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
	    ITEM = 'EVENT_SCET'
	    ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
	    PRINT*,RGSE/6.38E3,'OUTSIDE 40 RE',SCETI4
	    SCET8 = SCET8 + 1.D00
	    CALL W_CHANNEL_POSITION(CH,SCET8)
	    GO TO 100
	  ENDIF
C
	IF(RGSE.GT.9.6D04) THEN			! LIMIT 15 RE
C	    ADVANCE BY ONE HOUR AND GET ANOTHER EVENT
C	    ITEM = 'EVENT_SCET_R8'
C	    OK = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
	    ITEM = 'EVENT_SCET'
	    ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
C	    PRINT*,RGSE/6.38E3,'OUTSIDE 15 RE',SCETI4
	    SCET8 = SCET8 + 1.D00/24.D00
	    CALL W_CHANNEL_POSITION(CH,SCET8)
	    GO TO 100
	  ENDIF
C
C
CDIAG	PRINT*,'******START EVENT',NO_EVT1,NO_EVT,' *****'
	PRINT*,'******START EVENT',NO_EVT1,NO_EVT,' *****'
C
	DO N = 1,2048
	  DATA(N,1) = V1DATA(N)
	  DATA(N,2) = V2DATA(N)
	ENDDO
C	print*,'calling vmatrix2,event no. ',no_evt
C	DO CENTRAL HALF
	CALL VMATRIX2(DATA,512,1536)
C	CHANGE TO AMPLITUDE OF ELECTRIC FIELD
	EEIG1 = SQRT(EVAL(1))/41.1
	EEIG2 = SQRT(EVAL(2))/3.79
	IF(EEIG2.LT..2*EEIG1) THEN
	   PRINT*,'EVENT ',NO_EVT,' TOO LINEAR, GO TO 100'
	   GO TO 100
	ENDIF
C
	XMAX = 0.
	YMAX = 0.
	XMIN = 0.
	YMIN = 0.
	DO N = 1,2048
	  XMAX = AMAX1(XMAX,V1DATA(N))
	  YMAX = AMAX1(YMAX,V2DATA(N))
	  XMIN = AMIN1(XMIN,V1DATA(N))
	  YMIN = AMIN1(YMIN,V2DATA(N))
	ENDDO
	CRIT = .5
C****
	XMAX = AMAX1(XMAX,-XMIN)
	YMAX = AMAX1(YMAX,-YMIN)
C****
	XMAX = CRIT*XMAX
	YMAX = CRIT*YMAX
	XCOUNT = 0.
	YCOUNT = 0.
	DO N = 1,2048
	  IF(ABS(V1DATA(N)).GT.XMAX) XCOUNT = XCOUNT + 1.
	  IF(ABS(V2DATA(N)).GT.YMAX) YCOUNT = YCOUNT + 1.
	ENDDO
C
	DO N = 1,2048
	  N1DATA(N) = N1DATA(N) - 128
	  N2DATA(N) = N2DATA(N) - 128
	ENDDO
C
C	FIND ZERO CROSSINGS
C
	IZCNT = 1
	ZCROSS(IZCNT) = 0.
	IL = 1
	IZ = IL
C	  IF(N1DATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,N1DATA(IL),N1DATA(IL+1)
C
C	FIRST HALF OF CHANNEL 1
C
	DO IL = 1,1023
C
C	    IF(N1DATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,N1DATA(IL-1),
C     1     N1DATA(IL),N1DATA(IL+1)
C
C		COUNT ONLY POS TO NEG
C
	    IF(N1DATA(IL).GT.0.AND.N1DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N1DATA(IL)
		S2 = N1DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	    ENDIF
	ENDDO
C
	ZCNT1 = IZCNT
C
	AVR1_1ST_HALF = 1023./ZCNT1
	NZCNT1 = IZCNT
C
	Z1MAX = 0.
	DO N = 1,IZCNT-1
	  Z1INT(N) = ZCROSS(N+1) - ZCROSS(N)
	  Z1MAX = AMAX1(Z1INT(N),Z1MAX)
C	  IF(Z1INT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(Z1INT(N).EQ.0.) Z1INT(N) = 1.E-6
	ENDDO
C
C	SECOND HALF OF CHANNEL 1
C
	DO IL = 1024,2047
C
C		COUNT ONLY POS TO NEG
C
	    IF(N1DATA(IL).GT.0.AND.N1DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N1DATA(IL)
		S2 = N1DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	    ENDIF
	ENDDO
	IZCNT = IZCNT + 1
	ZCROSS(IZCNT) = 2048.
C
	AVR1_2ND_HALF = 1023./(IZCNT-NZCNT1)
C
	Z1MAX = 0.
	DO N = NZCNT1,IZCNT-1
	  Z1INT(N) = ZCROSS(N+1) - ZCROSS(N)
	  if(z1int(n).gt.z1max) then
	     z1max = z1int(n)
	     nnmax = n
	  endif
C	  IF(Z1INT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(Z1INT(N).EQ.0.) Z1INT(N) = 1.E-6
	ENDDO
CDIAG	print*,'max int ch 1',z1max,' at',zcross(nnmax),zcross(nnmax+1)
C
C	NOW AVR1_1ST_HALF IS THE AVERAGE INTERVAL, IN NUMBER OF SAMPLES
C	IN THE FIRST HALF OF THE EVENT, AND Z1MAX IS THE MAXIMUM
C	INTERVAL IN THE SECOND HALF.  Z1MAX IS EXPECTED TO BE LARGE
C	FOR BLOBS
C
CDAIG	print*,'zero crossings, ch 1,AVR1_1ST_HALF,Z1MAX',NO_EVT,izcnt,
CDIAG     1		AVR1_1ST_HALF,Z1MAX
	IF(Z1MAX.GT.5.*AVR1_1ST_HALF.AND.Z1MAX.GT.220.) THEN
C	  PRINT*,NO_EVT,'  CH 1 BLOB',AVR1_1ST_HALF,Z1MAX
C	  ITEM = 'SUN_ANGLE'
C	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	  write(51,*) no_evt,avr1_1st_half,z1max,sunclock
	  IFOUND = 0
	  GO TO 100
	ENDIF
C
	ZCNT1 = IZCNT

C
C	FIRST HALF OF CHANNEL 2
C
	IZCNT = 1
	ZCROSS(IZCNT) = 1.
C
	DO IL = 1,1023
C
C		COUNT ONLY POS TO NEG
C
	  IF(N2DATA(IL).GT.0.AND.N2DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N2DATA(IL)
		S2 = N2DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	  ENDIF
	ENDDO
C
	AVR2_1ST_HALF = 1023./IZCNT
	NZCNT2 = IZCNT
C
C	SECOND HALF OF CHANNEL 2
C
	DO IL = 1025,2047
C
C		COUNT ONLY POS TO NEG
C
	  IF(N2DATA(IL).GT.0.AND.N2DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N2DATA(IL)
		S2 = N2DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	  ENDIF
	ENDDO
	IZCNT = IZCNT + 1
	ZCROSS(IZCNT) = 2048.
C
	Z2MAX = 0.
	DO N = NZCNT2,IZCNT-1
	  Z2INT(N) = ZCROSS(N+1) - ZCROSS(N)
c	  Z2MAX = AMAX1(Z2INT(N),Z2MAX)
	  if(z2int(n).gt.z2max) then
	     z2max = z2int(n)
	     nnmax = n
	  endif
C	  IF(Z2INT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(Z2INT(N).EQ.0.) Z2INT(N) = 1.E-6
	ENDDO
C	print*,'max int ch 2',z2max,' at',zcross(nnmax),zcross(nnmax+1)
CDIAG	print*,'zero crossings, ch 2,AVR2_1ST_HALF,Z2MAX',NO_EVT,izcnt,
CDIAG     1		AVR2_1ST_HALF,Z2MAX
	IF(Z2MAX.GT.5.*AVR2_1ST_HALF.AND.Z2MAX.GT.220.) THEN
C	  PRINT*,NO_EVT,' CH 2 BLOB',AVR2_1ST_HALF,Z2MAX
C	  ITEM = 'SUN_ANGLE'
C	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	  write(52,*) no_evt,avr2_1st_half,z2max,sunclock
	  IFOUND = 0
	  GO TO 100
	ENDIF
C
	ZCNT2 = IZCNT
C
C	I FOUND THAT THERE ARE BLOBS AT RANDOM IN CHANNEL 2, PRESUMABLE
C	BECAUSE THE TRIGGER, FROM CHANNEL 1, SOMETIMES CATCHES
C	ONE AT RANDOM.  SO TEST FOR THESE
C
	AVR2_ALL = 2047./IZCNT
	Z3MAX = 0.
	DO N = 1,IZCNT-1
	  Z2INT(N) = ZCROSS(N+1) - ZCROSS(N)
	  if(z2int(n).gt.z3max) then
	     z3max = z2int(n)
	     nnmax = n
	  endif
	ENDDO
c	PRINT*,'TEST 3',NO_EVT,AVR2_ALL,Z3MAX,NNMAX
C
	IF(Z3MAX.GT.5.*AVR2_ALL.OR.Z3MAX.GT.220.) THEN
C	  PRINT*,NO_EVT,' CH 2 RANDOM BLOB',AVR2_1ST_HALF,Z3MAX
C	  ITEM = 'SUN_ANGLE'
C	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	  write(53,*) no_evt,avr2_all,z3max,sunclock,nnmax
	  IFOUND = 0
	  GO TO 100
	ENDIF
C
	ITEM = 'SOURCE'
	ok = W_ITEM_I4(ch, item, ISRC, 1, ret_size)
	ITEM = 'EVENT_NUMBER'
	ok = W_ITEM_I4(ch, item, NO_EVT, 1, ret_size)
	ITEM = 'EVENT_SCET'
	ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
	ITEM = 'FAST_RX_SPEED_R4'
	ok = W_ITEM_R4(ch, item, SPS, 1, ret_size)
        ITEM = 'EVENT_TM_SCET_I4'
        ok = W_ITEM_I4(ch, item, ERT, 2, ret_size)
        ERTDAY = MOD(ERT(1),100)
C	ITEM = 'WIND_MFI_BPHI(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, AZMAG, 1, ret_size)
C	ITEM = 'MAG_ELEVATION'
C	ok = W_ITEM_I4(ch, item, MAGEL, 1, ret_size)
C	ITEM = 'SUN_ANGLE'
C	ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	ITEM = 'WIND_3DP_E_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPE, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPI, 1, ret_size)
	ITEM = 'WIND_3DP_ION_DENSITY_R4'
	ok = W_ITEM_R4(ch, item, DENS, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_VX(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, VX, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_VY(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, VY, 1, ret_size)
	ITEM = 'WIND_MFI_BMAG_R4'
	ok = W_ITEM_R4(ch, item, BMAG, 1, ret_size)
C	ITEM = 'WIND_SPIN_RATE_R4'
C	ok = W_ITEM_R4(ch, item, SPINRATE, 1, ret_size)
C	if(ok.ne.1) then
	  spinrate = 2.
C	endif
C
C	CALCULATE FREQUENCIES FOR SPECTRUM
C
	DO N = 1,1024
	  FREQ(N) = (N-1)*SPS/2048.    ! FREQ(N) GOES WITH DBSPECT(N)
	ENDDO
C
C	CALCULATE BANDWIDTH, ETC.
C
	FLLIM = 4
	FUPLIM = 205			! 12 KHZ AT 120 KSPS
C	PRINT*,'DO FREQS',FREQ(FLLIM),FREQ(FUPLIM)
	DO NC = 1,2
	  FCOUNT(NC) = 1.E-20
	  FAVR(NC) = 0.
	  FSTD(NC) = 0.
	  F3MOM(NC) = 0.
	  DO N = FLLIM,FUPLIM
	    IF(NC.EQ.1) THEN
		VLT = 10.**(.1*DBSPEC1(N))
	    ELSE
		VLT = 10.**(.1*DBSPEC2(N))
	    ENDIF
	    FCOUNT(NC) = FCOUNT(NC) + VLT
	    FAVR(NC) = FAVR(NC) + VLT*FREQ(N)
	    FSTD(NC) = FSTD(NC) + VLT*FREQ(N)**2
	    F3MOM(NC) = F3MOM(NC) + VLT*FREQ(N)**3
	  ENDDO
	  FAVR(NC) = FAVR(NC)/FCOUNT(NC)
	  FSTD(NC) = FSTD(NC)/FCOUNT(NC) - FAVR(NC)**2
	  FBW(NC) = SQRT(AMAX1(FSTD(NC),0.))
	  SKEW(NC) = F3MOM(NC)/FCOUNT(NC) - 3.*FAVR(NC)*FSTD(NC)
     1		 - FAVR(NC)**3
	ENDDO
C
	AVRPER = 1.E-6
	IF(ZCNT2.NE.0.) AVRPER = 2048./SPS/ZCNT2
	FREQKHZ = .001/AVRPER
C
C	WRITE(56,1111) SCETI4(1),NO_EVT,FREQKHZ,FAVR(1),FAVR(2),FBW(1)
C     1	  ,FBW(2),SKEW(1),SKEW(2)
 1111	FORMAT(I10,I10,F7.3,2F8.0,2E11.3,2E11.3)
C****
C	WRITE(37,*), NO_EVT,XMAX,YMAX,XCOUNT,YCOUNT
C****
C	ANGLE =  -360.*SUNCLOCK/4096. - 45.       ! ANGLE SUN TO +EX AT END
C	DANG = SPINRATE*360./SPS/TWOPI		  ! CHANGE PER SAMPLE
C	THANT = ANGLE + 1024.*DANG + 360.	  ! ANGLE SUN TO +EX AT MIDDLE
C
	FP = -1.
	IF(DENS.GT.0.) FP = 9.*SQRT(DENS)			  ! PLASMA FREQ IN KHZ
	FCE = .028*BMAG
C	BETA = .402*(TEMPE+TEMPI)/BMAG**2
C
	  IFOUND = 0
c		to exclude cals
	  if(sceti4(2).lt.010000.or.sceti4(2).gt.011000) then
	      write(90,1054) SCETI4,ERTDAY,EVENT(1:1),NO_EVT,MAXCH1,MAXCH2,
     1		E1MAX,E2MAX,EEIG1,EEIG2,FREQKHZ,FP,FCE
 1054	  FORMAT(I10,I7,I3,A2,I10,2I4,4E11.3,3F8.2)
	  endif
	  GO TO 100
C	IF(Z1MAX.GT.2.*Z2MAX) THEN
c	  PRINT*,'EVENT NO.',NO_EVT,' A BIG GAP',Z1MAX,Z2MAX
c	  ITEM = 'SUN_ANGLE'
c	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
c	  write(55,*) no_evt,sunclock,z1max,z2max
C	  IFOUND = 0
C	  GO TO 100
C	ENDIF
c	the following test eliminated a good event, 14583199 19960527
c	IF(ZCNT1.LT..7*ZCNT2) THEN
c	  PRINT*,'EVENT NO.',NO_EVT,' NOT ENOUGH ZERO CROSSING IN CH 1'
c	  IFOUND = 0
c	  GO TO 100
c	ENDIF
C
C*****	CHECKING
c	PRINT*,'VMATRIX',VMATRIX(1,1),VMATRIX(1,2),VMATRIX(2,2)
c	PRINT*,'EVALS,AXS,PX,PY',EVAL(1),EVAL(2),AXMAJOR,AXMINOR,
c     1		PX,PY
C*****
C
C	PLASMA PARAMETERS, ETC.

C	   write(s,'(i8.8,i6.6)',iostat=ios) s_scet(1), s_scet(2)
C	   s_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
C	1	s(9:10)//':'//s(11:12)//':'//s(13:14)
C
c	print date, time, event no., freq, Px, Py, Vy/Vx, angles of
c		antenna,B, phiB, mag B or fce, fp
c
c	PRINT*, 'PXTOT,PYTOT,RATIO',PXTOT,PYTOT,XYRATIO
C
C	  WRITE(90,1011) NO_EVT,sceti4,FREQKHZ,PX,PY,SLOPE,ANGTOB,
C     1	     AZMAG,MAGEL,FP,FCE,BETA,XCOUNT,YCOUNT
C 1011	format(I10,I7,I10,I3,F7.2,2E10.3,F8.3,2F7.1,I5,F7.3,F7.4,F8.4,2F7.0)
C	THE FOLLOWING IS A STANDARD FORMAT FOR READING IN TDSVIS
 1114   FORMAT(I10,I7,I10,I3,A2,3F7.0,F7.2,F6.2,F7.0,F6.1,3F7.1,2F7.1)
	IF(OK.NE.82) GO TO 100
	return
	end


module da_obs_io

   use module_domain, only : domain

   use da_control, only : xmiss, missing_r, fmt_each, fmt_info, trace_use, &
      fmt_srfc, filtered_obs_unit, num_procs,missing, ierr,comm, rand_unit, &
      obs_qc_pointer, rootproc, omb_unit,omb_add_noise,use_airepobs, &
      use_airepobs,use_bogusobs,use_gpspwobs,use_gpsztdobs,use_gpsrefobs,use_geoamvobs, &
      use_metarobs,use_profilerobs,use_pilotobs,use_buoyobs,use_shipsobs,use_rainobs, &
      use_synopobs,use_soundobs,use_mtgirsobs,use_tamdarobs,use_qscatobs,use_radarobs, &
      test_transforms, use_ssmiretrievalobs, report_start, &
      report_end, global, print_detail_obs, stdout, t_kelvin, stderr, &
      max_ob_levels, missing_data, max_bogus_input, myproc, convert_uv2fd, convert_fd2uv, &
      fails_error_max,standard_atmosphere,zero_t_td,print_detail_f_obs, &
      print_detail_radar,use_satemobs,use_polaramvobs,use_ssmt1obs, &
      use_ssmt2obs, use_airsretobs,convert_fd2uv,anal_type_qcobs,gravity,gas_constant,cp, &
      filename_len, t0, max_airep_input, max_bogus_input, max_ssmi_rv_input, &
      max_buoy_input, max_gpsref_input, max_gpspw_input, max_geoamv_input, &
      max_airsr_input, max_polaramv_input, max_radar_input, &
      max_profiler_input, max_sound_input, max_mtgirs_input, max_tamdar_input, max_ships_input, &
      max_satem_input,max_pilot_input, max_metar_input, max_ssmt1_input, &
      max_synop_input,max_ssmt2_input,  max_qscat_input, &
      obs_names, num_ob_indexes, fm_index, ids,ide, ite, jte, &
      sound, mtgirs,synop, pilot, satem, geoamv, polaramv, airep, gpspw, gpsref, &
      tamdar, tamdar_sfc, metar, ships, ssmi_rv, ssmi_tb, ssmt1, ssmt2, qscat, profiler, buoy, bogus, pseudo, &
      radar, radiance, airsr, sonde_sfc, trace_use_dull, num_fgat_time, time_slots, myproc, &
      qmarker_retain, anal_type_verify, top_km_gpsro, bot_km_gpsro, thin_rainobs, &
      sfc_assi_options, sfc_assi_options_1, sfc_assi_options_2,print_detail_rain,max_rain_input,rain, &
      pi, ob_format_gpsro, ob_format_ascii, analysis_date, kms,kme, v_interp_h,v_interp_p, &
      wind_sd,wind_sd_synop,wind_sd_tamdar,wind_sd_mtgirs,wind_sd_profiler,wind_sd_geoamv,wind_sd_polaramv, &
      wind_sd_airep,wind_sd_sound,wind_sd_metar,wind_sd_ships,wind_sd_qscat,wind_sd_buoy,wind_sd_pilot,wind_stats_sd,&
      thin_conv, thin_conv_ascii, lsac_nh_step, lsac_nv_step, lsac_nv_start, lsac_print_details, &
      lsac_use_u, lsac_use_v, lsac_use_t, lsac_use_q, lsac_u_error, lsac_v_error, lsac_t_error, lsac_q_error, &
      gpsro_drift, max_gpseph_input, use_gpsephobs, gpseph, gpseph_loadbalance, kds, kde, kts, kte, &
      use_radar_rhv, use_radar_rqv

   use da_wrf_interfaces, only : wrf_dm_bcast_integer, wrf_dm_bcast_real
   use da_define_structures, only : iv_type, multi_level_type, multi_level_type_BUFR, &
      radar_multi_level_type, y_type, field_type, each_level_type, &
      radar_each_level_type, info_type, model_loc_type,gpsref_type, rain_single_level_type, rain_each_type, &
      gpseph_type
   use da_grid_definitions, only : da_ffdduv,da_ffdduv_model,da_ffdduv_diagnose
   use da_obs, only : da_count_filtered_obs,da_check_missing,da_obs_proc_station, da_set_obs_missing, da_set_3d_obs_missing
   use da_par_util1, only : da_proc_sum_int
   use da_physics, only : da_tp_to_qs
   use da_reporting, only : da_warning, message, da_error
   use da_tools, only : da_llxy, da_get_julian_time, da_geo2msl1, da_msl2geo1
   use da_tools_serial, only : da_free_unit, da_get_unit, da_advance_time
   use da_tracing, only : da_trace_entry, da_trace_exit

   use module_radiance, only : deg2rad, i_kind
   use gsi_thinning, only : map2grids, map2grids_conv, cleangrids_conv, thinning_grid, &
                            map2tgrid, thinning_grid_conv
#ifdef DM_PARALLEL
   use da_control, only : root
!  use mpi, only : mpi_min
   use da_par_util, only : true_mpi_real
#endif
#ifdef BUFR
   use da_grid_definitions, only : da_earth_2_model_wind
#endif
   use da_reporting, only : message, da_message
   use da_interpolation, only : da_to_zk
   use da_netcdf_interface, only : da_get_var_3d_real_cdf, da_get_dims_cdf, &
      da_get_var_2d_real_cdf
   use da_gpseph, only: da_gpseph_create_ob, ob_in_mean_h, global_h_mean

   implicit none

#ifdef DM_PARALLEL
   include 'mpif.h'
#endif

contains

#include "da_read_obs_ascii.inc"
#include "da_scan_obs_ascii.inc"
#include "da_read_obs_radar.inc"
#include "da_scan_obs_radar.inc"
#include "da_scan_obs_rain.inc"
#include "da_read_obs_rain.inc"
#include "da_read_errfac.inc"
#include "da_use_obs_errfac.inc"
#include "da_write_obs.inc"
#include "da_write_iv_for_multi_inc.inc"
#include "da_read_iv_for_multi_inc.inc"
#include "da_search_obs.inc"
#include "da_write_obs_etkf.inc"
#include "da_write_filtered_obs.inc"
#include "da_write_modified_filtered_obs.inc"
#include "da_write_y.inc"
#include "da_read_obs_bufr.inc"
#include "da_read_obs_bufrgpsro.inc"
#include "da_read_obs_bufrgpsro_eph.inc"
#include "da_final_write_obs.inc"
#include "da_final_write_y.inc"
#include "da_read_y_unit.inc"
#include "da_read_rand_unit.inc"
#include "da_read_omb_tmp.inc"
#include "da_write_noise_to_ob.inc"
#include "da_final_write_filtered_obs.inc"
#include "da_final_write_modified_filtered_obs.inc"
#include "da_read_lsac_util.inc"
#include "da_read_obs_lsac.inc"
#include "da_scan_obs_lsac.inc"

end module da_obs_io


  subroutine  coalesl (coalObj, results, maxA2, maxA3, maxA4, maxA6, maxA7)

! ======================================================================
!
!     Written by K. Gudima; uses the coalescence model
!     to "create" high-energy d, t, He-3, and He-4 from
!     emitted cascade nucleons;
!     Initial number of cascade particle kstart-1 is
!     recalculated.
!
!     Version for CEM2K2  20.03.2002 (rijmin=2.2)
!    "Last" change: 14-AUG-2003 by NVMokhov
!     Modified by A. J. Sierk, LANL T-16, October, 2003.
!     Modified to change p0 values for 300 < E < 1000 MeV
!     S. G. Mashnik, July, 2005.
!     Error corrected, AJS November, 2005.
!     Edited by AJS, LANL T-2, December, 2011.
!     Edited LMK, XCP-3, July 2013 (included error protection).
!     Modified by LMK, 2015, expanded coalescence to Be7.
!     Modified by CMJ, XCP-3, July 2018 (Coalescence class creation).
!     Modified by CMJ, XCP-3, Jan. 2019 (utilize less memory, ensure arrays don't overflow)
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use coalescenceParams, only : one, two, four, avg_mass

    implicit none
    class(Coalescence),       intent(inout) :: coalObj
    type(coalescenceResults), intent(inout) :: results
    integer(int32),           intent(in   ) :: maxA2
    integer(int32),           intent(in   ) :: maxA3
    integer(int32),           intent(in   ) :: maxA4
    integer(int32),           intent(in   ) :: maxA6
    integer(int32),           intent(in   ) :: maxA7

    integer(int32) :: i, iq, j, &
         & i1, i2, i3, i4, i5, i6, i7, ia, ib, ib1, id, it, itt, &
         & numDeut, numDeut1, numTrit, numAlpha, numHe6, numLi6, numA7
    real(real64)   :: &
         & cf1, cf2, cf3, cf4, cf5, cf6, cf7, cfj, &
         & ct1, ct2, ct3, ct4, ct5, ct6, ct7, ctj, &
         &  e1,  e2,  e3,  e4,  e5,  e6,  e7,  ej, es, &
         & sf1, sf2, sf3, sf4, sf5, sf6, sf7, sfj, &
         & st1, st2, st3, st4, st5, st6, st7, stj, &
         & t1s, t2s, t3s, t4s, t5s, t6s, t7s, tjs, &
         & temp, wi, wj
    integer(int32), dimension(7) :: ind=0_int32
    real(real64),   dimension(3) :: &
         & p1l=zro, p1s=zro, &
         & p2l=zro, p2s=zro, &
         & p3l=zro, p3s=zro, &
         & p4l=zro, p4s=zro, &
         & p5l=zro, p5s=zro, &
         & p6l=zro, p6s=zro, &
         & p7l=zro, p7s=zro, &
         & pjl=zro, pjs=zro, &
         &   v=zro

! ======================================================================

    ! Variables for calculation of coalescence particles
    real(real64),   parameter   :: he6Reduction = four       ! Reduce He6 production by a factor of 4 (abnormally high rates otherwise)
    real(real64),   parameter   :: p0Factor = two * avg_mass ! Factor for nucleon comparisons
! rmin = 1/p0 = 1/5.06/(0.090GeV/c):
!    real(real64), parameter :: rijmin= (1 / 5.06) / defaultCRDeut(1)

    ! Coalescence of [D] particles
    integer(int32), dimension(maxA2) :: id1, id2
    ! Coalescence of [T/He3] particles
    integer(int32), dimension(maxA3) :: it1, it2, it3
    ! Coalescence of [He4] particles
    integer(int32), dimension(maxA4) :: ia1, ia2, ia3, ia4
    ! [ ----- EXPANDED COALESCENCE ----- ]
    ! Coalescence of [He6] particles
    integer(int32), dimension(maxA6) :: ihe61, ihe62, ihe63, ihe64, &
         & ihe65, ihe66
    ! Coalescence of [Li6] particles
    integer(int32), dimension(maxA6) :: ili61, ili62, ili63, ili64, &
         & ili65, ili66
    ! Coalescence of [A=7] particles
    integer(int32), dimension(maxA7) :: i71, i72, i73, i74, i75, &
         & i76, i77
! ======================================================================

! ----------------
! Variable setup
! ---------------
    i = 1       ! Index of first nucleon to consider
    numDeut = 0      ! Number of formed deuterons
! LMK, 12/2014
    numA7 = 0      ! Number of formed A=7 particles
    numLi6 = 0    ! Number of formed Li6 fragments
    numHe6 = 0    ! Number of formed He6 fragments

    ! ---------------------------------------
    ! Start of main calculation:
    ! ---------------------------------------
10  continue
    wi = one

! (LMK) Only coalesce nucleons (filters all other INC fragments out)
    if (results%partBnk(i)%numBaryons  /=  1 .or. &
         & results%partBnk(i)%coalesceNum /= 0 .or. &
         & results%partBnk(i)%strangeness /= 0 .or. wi < one) then
       if (i > (results%numParticles-1)) go to 30
       i = i + 1
       go to 10
    endif
    j = i + 1

! Find allowed interacting nucleon
20  if (j > results%numParticles) then
       if (i > (results%numParticles-1)) go to 30
       i = i + 1
       go to 10
    endif
    wj = one
! (LMK) Only coalesce nucleons
    if (results%partBnk(j)%numBaryons /= 1 .or. results%partBnk(j)%coalesceNum /= 0 &
         & .or. results%partBnk(j)%strangeness /= 0 .or. wj < one) then
       j = j + 1
       go to 20
    endif

! Obtain nucleon information
    i1 = i
    e1 = results%partBnk(i1)%kinEnergy + avg_mass
    ej = results%partBnk(j)%kinEnergy + avg_mass
    pjl(1) = results%partBnk(j)%linearMomX
    pjl(2) = results%partBnk(j)%linearMomY
    pjl(3) = results%partBnk(j)%linearMomZ
    es = ej + e1
    p1l(1) = results%partBnk(i1)%linearMomX
    p1l(2) = results%partBnk(i1)%linearMomY
    p1l(3) = results%partBnk(i1)%linearMomZ
    temp = es
    if (temp < div0Limit .and. temp > -div0Limit) then
       temp = div0Limit
       write(coalObj%io%message, 2000) "249-251"
       call coalObj%io%print(4, 3, coalObj%io%message)
    end if
    v(1) = -(p1l(1) + pjl(1))/temp
    v(2) = -(p1l(2) + pjl(2))/temp
    v(3) = -(p1l(3) + pjl(3))/temp
    call coalObj%kinema (pjl, v, pjs, ctj, stj, cfj, sfj, tjs, avg_mass)
!    call rijm (i, j, rmin) !! Coalescence will ignore separation
!    if (rmin > rijmin .or. & !! in r-space; only consider p-space!
!         & sqrt(tjs*(tjs + p0Factor)) > coalObj%data%coalesRadiiDeut()) then !! SGM 07/07/05
!       j = j + 1
    temp = tjs*(tjs + p0Factor)
    if (temp < 0.0d0) then
       temp = sqrRootCorrection
       write(coalObj%io%message, 2100) "262"
       call coalObj%io%print(4, 3, coalObj%io%message)
    end if

    ! Check if partner's momentum is small enough
    if (sqrt(temp) > coalObj%data%coalesRadiiDeut()) then
       ! Participant won't coalesce, find new partner
       j = j + 1
       go to 20
    endif

    results%numCoalesced = results%numCoalesced + 2 ! 2 nucleons coalesed into a 'd' (n+p)
    ! if space remains in the internal array, add a deuteron (coalesced)
    if (numDeut < maxA2 ) then
! (LMK) Coalesce a deuteron
       numDeut = numDeut + 1
       id1(numDeut) = i
       id2(numDeut) = j
       results%partBnk(i)%coalesceNum = numDeut
       results%partBnk(j)%coalesceNum = numDeut
       if (i <= results%numParticles-1) then
          ! Find another set of nucleons to coalesce
          i = i + 1
          go to 10
       endif
    else
       ! Arrays exceeded!
       write(coalObj%io%message, 1500) "deuteron"
       call coalObj%io%print(1, 3, coalObj%io%message)
    endif

! Check for coalesced alpha particles (from the coalesced deuterons, d+d)
30  numAlpha = 0
    if (numDeut >= 2) then
       numDeut1 = numDeut - 1
       do id = 1,numDeut1
          ! Obtain index of deuteron's nucleons (not yet coalesced)
          i1 = id1(id)
          i2 = id2(id)

          if (i1 == 0) go to 50 ! No more deuterons to coalesce

          ! Look for another deuteron check if can coalesce with the previously found one
          ib1 = id + 1
          do ib = ib1,numDeut
             ! Obtain deuteron index
             i3 = id1(ib)
             j = id2(ib)

             if (i3 == 0) go to 40 ! No more deuterons to coalesce with

             ! Obtain the fragment charge, check if charge is that of helium
             iq = results%partBnk(i1)%charge + results%partBnk(i2)%charge + &
                  & results%partBnk(i3)%charge + results%partBnk(j)%charge
             if (iq /= 2) go to 40
             ! Obtain energy and momentum of each nucleons
             e1 = results%partBnk(i1)%kinEnergy + avg_mass
             e2 = results%partBnk(i2)%kinEnergy + avg_mass
             e3 = results%partBnk(i3)%kinEnergy + avg_mass
             ej = results%partBnk(j)%kinEnergy + avg_mass
             p1l(1) = results%partBnk(i1)%linearMomX
             p1l(2) = results%partBnk(i1)%linearMomY
             p1l(3) = results%partBnk(i1)%linearMomZ
             p2l(1) = results%partBnk(i2)%linearMomX
             p2l(2) = results%partBnk(i2)%linearMomY
             p2l(3) = results%partBnk(i2)%linearMomZ
             p3l(1) = results%partBnk(i3)%linearMomX
             p3l(2) = results%partBnk(i3)%linearMomY
             p3l(3) = results%partBnk(i3)%linearMomZ
             pjl(1) = results%partBnk(j)%linearMomX
             pjl(2) = results%partBnk(j)%linearMomY
             pjl(3) = results%partBnk(j)%linearMomZ
             es = ej + e1 + e2 + e3 ! Obtain total energy
             temp = es
             if (temp < div0Limit .and. temp > -div0Limit) then
                temp = div0Limit
                write(coalObj%io%message, 2000) "317-319"
                call coalObj%io%print(4, 3, coalObj%io%message)
             end if
             v(1) = -(p1l(1) + p2l(1) + p3l(1) + pjl(1))/temp
             v(2) = -(p1l(2) + p2l(2) + p3l(2) + pjl(2))/temp
             v(3) = -(p1l(3) + p2l(3) + p3l(3) + pjl(3))/temp
             call coalObj%kinema (p1l, v, p1s, ct1, st1, cf1, sf1, t1s, avg_mass)
             call coalObj%kinema (p2l, v, p2s, ct2, st2, cf2, sf2, t2s, avg_mass)
             call coalObj%kinema (p3l, v, p3s, ct3, st3, cf3, sf3, t3s, avg_mass)
             call coalObj%kinema (pjl, v, pjs, ctj, stj, cfj, sfj, tjs, avg_mass)

! Check if nucleons can coalesce
! (LMK, Altered comparison to eliminate LHS sqrt)
             if (t1s*(t1s + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 40
             if (t2s*(t2s + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 40
             if (t3s*(t3s + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 40
             if (tjs*(tjs + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 40

             if (numAlpha >= maxA4 ) then
                ! Arrays exceeded!
                write(coalObj%io%message, 1500) "alpha"
                call coalObj%io%print(1, 3, coalObj%io%message)
             else
! (LMK) Coalesce an alpha particle
                numAlpha = numAlpha + 1
                ia1(numAlpha) = i1
                ia2(numAlpha) = i2
                ia3(numAlpha) = i3
                ia4(numAlpha) = j
                ! Set flag for coalesced nucleons (for alpha)
                results%partBnk(i1)%coalesceNum = numAlpha
                results%partBnk(i2)%coalesceNum = numAlpha
                results%partBnk(i3)%coalesceNum = numAlpha
                results%partBnk(j)%coalesceNum = numAlpha
                ! Remove deuteron flag
                id1(id) = 0
                id2(id) = 0
!  Misprint found by AJS 11/18/05
!                id1(id) = 0
!                id2(id) = 0
                id1(ib) = 0
                id2(ib) = 0
                go to 50 ! Deuterons have coalesced; look for a new pair
             endif
40           continue
          end do
50        continue
       end do
    endif

    ! Coalesce tritons/He-3 (d+n or d+p)
    numTrit = 0
    if (numDeut == 0) go to 150
    do id = 1,numDeut
       i1 = id1(id)
       i2 = id2(id)
       if (i1 /= 0) then
          do j = 1,results%numParticles
             wj = one

             if (results%partBnk(j)%numBaryons /= 1     .or. &
                  & results%partBnk(j)%coalesceNum /= 0 .or. &
                  & results%partBnk(j)%strangeness /= 0 .or. wj < one) go to 70

             iq = results%partBnk(i1)%charge + results%partBnk(i2)%charge + &
                  results%partBnk(j)%charge

             ! Get rid of 3n or 3p coalesced groups, LMK
             if (iq == 0 .or. iq == 3) go to 70

             e1 = results%partBnk(i1)%kinEnergy + avg_mass
             e2 = results%partBnk(i2)%kinEnergy + avg_mass
             ej = results%partBnk(j)%kinEnergy + avg_mass
             p1l(1) = results%partBnk(i1)%linearMomX
             p1l(2) = results%partBnk(i1)%linearMomY
             p1l(3) = results%partBnk(i1)%linearMomZ
             p2l(1) = results%partBnk(i2)%linearMomX
             p2l(2) = results%partBnk(i2)%linearMomY
             p2l(3) = results%partBnk(i2)%linearMomZ
             pjl(1) = results%partBnk(j)%linearMomX
             pjl(2) = results%partBnk(j)%linearMomY
             pjl(3) = results%partBnk(j)%linearMomZ
             es = ej + e1 + e2
             temp = es
             if (temp < div0Limit .and. temp > -div0Limit) then
                temp = div0Limit
                write(coalObj%io%message, 2000) "389-391"
                call coalObj%io%print(4, 3, coalObj%io%message)
             end if
             v(1) = -(p1l(1) + p2l(1) + pjl(1))/temp
             v(2) = -(p1l(2) + p2l(2) + pjl(2))/temp
             v(3) = -(p1l(3) + p2l(3) + pjl(3))/temp
             call coalObj%kinema (p1l, v, p1s, ct1, st1, cf1, sf1, t1s, avg_mass)
             call coalObj%kinema (p2l, v, p2s, ct2, st2, cf2, sf2, t2s, avg_mass)
             call coalObj%kinema (pjl, v, pjs, ctj, stj, cfj, sfj, tjs, avg_mass)
! LMK, Altered comparison to eliminate LHS sqrt
             if (t1s*(t1s + p0Factor) > coalObj%data%coalesRadiiTritSqrd()) go to 70
             if (t2s*(t2s + p0Factor) > coalObj%data%coalesRadiiTritSqrd()) go to 70
             if (tjs*(tjs + p0Factor) > coalObj%data%coalesRadiiTritSqrd()) go to 70

             ! One nucleon coalesced w/ a d (d+n or d+p)
             results%numCoalesced = results%numCoalesced + 1

             if (numTrit >= maxA3 ) then
                write(coalObj%io%message, 1500) "triton or helion"
                call coalObj%io%print(1, 3, coalObj%io%message)
             else
! (LMK) Coalesce a triton or 3He
                numTrit = numTrit + 1
                it1(numTrit) = i1
                it2(numTrit) = i2
                it3(numTrit) = j
                results%partBnk(i1)%coalesceNum = numTrit
                results%partBnk(i2)%coalesceNum = numTrit
                results%partBnk(j)%coalesceNum = numTrit
                id1(id) = 0
                id2(id) = 0
                go to 80
             endif
70           continue
          end do
       endif
80     continue
    end do

    ! Coalesce more He4 (t+p or He3+n)
    if (numTrit > 0) then
       do it = 1,numTrit
          do j = 1,results%numParticles
             wj = one
             if (results%partBnk(j)%numBaryons /= 1     .or. &
                  & results%partBnk(j)%coalesceNum /= 0 .or. &
                  & results%partBnk(j)%strangeness /= 0 .or. wj < one) go to 90
             i1 = it1(it)
             i2 = it2(it)
             i3 = it3(it)
             iq = results%partBnk(i1)%charge + results%partBnk(i2)%charge + &
                  & results%partBnk(i3)%charge + results%partBnk(j)%charge
             if (iq /= 2) go to 90
! Make sure combination is t+p, or 3He+n, to coalesce 4He, LMK  ^^^^^
             e1 = results%partBnk(i1)%kinEnergy + avg_mass
             e2 = results%partBnk(i2)%kinEnergy + avg_mass
             e3 = results%partBnk(i3)%kinEnergy + avg_mass
             ej = results%partBnk(j)%kinEnergy + avg_mass
             p1l(1) = results%partBnk(i1)%linearMomX
             p1l(2) = results%partBnk(i1)%linearMomY
             p1l(3) = results%partBnk(i1)%linearMomZ
             p2l(1) = results%partBnk(i2)%linearMomX
             p2l(2) = results%partBnk(i2)%linearMomY
             p2l(3) = results%partBnk(i2)%linearMomZ
             p3l(1) = results%partBnk(i3)%linearMomX
             p3l(2) = results%partBnk(i3)%linearMomY
             p3l(3) = results%partBnk(i3)%linearMomZ
             pjl(1) = results%partBnk(j)%linearMomX
             pjl(2) = results%partBnk(j)%linearMomY
             pjl(3) = results%partBnk(j)%linearMomZ
             es = ej + e1 + e2 + e3
             temp = es
             if (temp < div0Limit .and. temp > -div0Limit) then
                temp = div0Limit
                write(coalObj%io%message, 2000) "453-455"
                call coalObj%io%print(4, 3, coalObj%io%message)
             end if
             v(1) = -(p1l(1) + p2l(1) + p3l(1) + pjl(1))/temp
             v(2) = -(p1l(2) + p2l(2) + p3l(2) + pjl(2))/temp
             v(3) = -(p1l(3) + p2l(3) + p3l(3) + pjl(3))/temp
             call coalObj%kinema (p1l, v, p1s, ct1, st1, cf1, sf1, t1s, avg_mass)
             call coalObj%kinema (p2l, v, p2s, ct2, st2, cf2, sf2, t2s, avg_mass)
             call coalObj%kinema (p3l, v, p3s, ct3, st3, cf3, sf3, t3s, avg_mass)
             call coalObj%kinema (pjl, v, pjs, ctj, stj, cfj, sfj, tjs, avg_mass)
! LMK, Altered comparison to eliminate LHS sqrt
             if (t1s*(t1s + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 90
             if (t2s*(t2s + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 90
             if (t3s*(t3s + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 90
             if (tjs*(tjs + p0Factor) > coalObj%data%coalesRadiiAlphaSqrd()) go to 90

             ! 1 Nucleon coalesced (t+p or He3+n)
             results%numCoalesced = results%numCoalesced + 1

             if (numAlpha >= maxA4 ) then
                write(coalObj%io%message, 1500) "alpha"
                call coalObj%io%print(1, 3, coalObj%io%message)
             else
! Coalesce 4He from t+p or 3He+n, LMK
                numAlpha = numAlpha + 1
                ia1(numAlpha) = i1
                ia2(numAlpha) = i2
                ia3(numAlpha) = i3
                ia4(numAlpha) = j
                results%partBnk(i1)%coalesceNum = numAlpha
                results%partBnk(i2)%coalesceNum = numAlpha
                results%partBnk(i3)%coalesceNum = numAlpha
                results%partBnk(j)%coalesceNum = numAlpha
                it1(it) = 0
                it2(it) = 0
                it3(it) = 0
                go to 100
             endif
90           continue
          end do
100       continue
       end do
    endif

! (LMK, 12/2014) Add coalescence of 6He, 6,7Li, 7Be
! [He4 + t/He3, He4 + d/2n]
    if ( coalObj%options%expandedCoalescence > 0 ) then
       do ia = 1, numAlpha
          if (ia4(ia) < 0.5) cycle   ! Check for 4He already coalesced...
          i1 = ia1(ia)
          i2 = ia2(ia)
          i3 = ia3(ia)
          i4 = ia4(ia)
          e1 = results%partBnk(i1)%kinEnergy + avg_mass
          e2 = results%partBnk(i2)%kinEnergy + avg_mass
          e3 = results%partBnk(i3)%kinEnergy + avg_mass
          e4 = results%partBnk(i4)%kinEnergy + avg_mass
          p1l(1) = results%partBnk(i1)%linearMomX
          p1l(2) = results%partBnk(i1)%linearMomY
          p1l(3) = results%partBnk(i1)%linearMomZ
          p2l(1) = results%partBnk(i2)%linearMomX
          p2l(2) = results%partBnk(i2)%linearMomY
          p2l(3) = results%partBnk(i2)%linearMomZ
          p3l(1) = results%partBnk(i3)%linearMomX
          p3l(2) = results%partBnk(i3)%linearMomY
          p3l(3) = results%partBnk(i3)%linearMomZ
          p4l(1) = results%partBnk(i4)%linearMomX
          p4l(2) = results%partBnk(i4)%linearMomY
          p4l(3) = results%partBnk(i4)%linearMomZ
          do it = 1, numTrit ! Coalesce 7Be, 7Li, a+t
             if (it3(it) < 0.5) cycle    ! Check for t/3He already coalesced...
             i5 = it1(it)
             i6 = it2(it)
             i7 = it3(it)
             e5 = results%partBnk(i5)%kinEnergy + avg_mass
             e6 = results%partBnk(i6)%kinEnergy + avg_mass
             e7 = results%partBnk(i7)%kinEnergy + avg_mass
             p5l(1) = results%partBnk(i5)%linearMomX
             p5l(2) = results%partBnk(i5)%linearMomY
             p5l(3) = results%partBnk(i5)%linearMomZ
             p6l(1) = results%partBnk(i6)%linearMomX
             p6l(2) = results%partBnk(i6)%linearMomY
             p6l(3) = results%partBnk(i6)%linearMomZ
             p7l(1) = results%partBnk(i7)%linearMomX
             p7l(2) = results%partBnk(i7)%linearMomY
             p7l(3) = results%partBnk(i7)%linearMomZ
             es = e1 + e2 + e3 + e4 + e5 + e6 + e7
             if (es > 0) then
                v(1) = -(p1l(1) + p2l(1) + p3l(1) + p4l(1) + p5l(1) + p6l(1) &
                     & + p7l(1))/es
                v(2) = -(p1l(2) + p2l(2) + p3l(2) + p4l(2) + p5l(2) + p6l(2) &
                     + p7l(2))/es
                v(3) = -(p1l(3) + p2l(3) + p3l(3) + p4l(3) + p5l(3) + p6l(3) &
                     + p7l(3))/es
             else
                v(:) = 0.0d0
                write(coalObj%io%message, 2000) "538"
                call coalObj%io%print(4, 3, coalObj%io%message)
             end if
             call coalObj%kinema (p1l, v, p1s, ct1, st1, cf1, sf1, t1s, avg_mass)
             call coalObj%kinema (p2l, v, p2s, ct2, st2, cf2, sf2, t2s, avg_mass)
             call coalObj%kinema (p3l, v, p3s, ct3, st3, cf3, sf3, t3s, avg_mass)
             call coalObj%kinema (p4l, v, p4s, ct4, st4, cf4, sf4, t4s, avg_mass)
             call coalObj%kinema (p5l, v, p5s, ct5, st5, cf5, sf5, t5s, avg_mass)
             call coalObj%kinema (p6l, v, p6s, ct6, st6, cf6, sf6, t6s, avg_mass)
             call coalObj%kinema (p7l, v, p7s, ct7, st7, cf7, sf7, t7s, avg_mass)
             if (t1s*(t1s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t2s*(t2s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t3s*(t3s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t4s*(t4s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t5s*(t5s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t6s*(t6s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t7s*(t7s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle

! Coalesced 7Be or 7Li
             numA7 = numA7 + 1
             if (numA7 <= maxA7 ) then
                i71(numA7) = i1
                i72(numA7) = i2
                i73(numA7) = i3
                i74(numA7) = i4
                i75(numA7) = i5
                i76(numA7) = i6
                i77(numA7) = i7
                results%partBnk(i1)%coalesceNum = numA7
                results%partBnk(i2)%coalesceNum = numA7
                results%partBnk(i3)%coalesceNum = numA7
                results%partBnk(i4)%coalesceNum = numA7
                results%partBnk(i5)%coalesceNum = numA7
                results%partBnk(i6)%coalesceNum = numA7
                results%partBnk(i7)%coalesceNum = numA7
                ia1(ia) = 0
                ia2(ia) = 0
                ia3(ia) = 0
                ia4(ia) = 0
                it1(it) = 0
                it2(it) = 0
                it3(it) = 0
             else
                write(coalObj%io%message, 1500) "Li7 or Be7"
                call coalObj%io%print(1, 3, coalObj%io%message)
             end if
             exit
          end do ! numTrit loop
          if (ia4(ia) < 0.5) cycle      ! If alpha was coalesced, skip to next alpha

! Coalesce 6Li or 6He, a+d
          do id = 1, numDeut
             if (id2(id) < 0.5) cycle    ! Check for d already coalesced...
             i5 = id1(id)
             i6 = id2(id)
             ! Check for coalesced 6Be and cycle
             if ( (results%partBnk(i1)%charge + results%partBnk(i2)%charge + &
                  & results%partBnk(i3)%charge + results%partBnk(i4)%charge + &
                  & results%partBnk(i5)%charge + results%partBnk(i6)%charge) > 3.5) &
                  & cycle
             e5 = results%partBnk(i5)%kinEnergy + avg_mass
             e6 = results%partBnk(i6)%kinEnergy + avg_mass
             p5l(1) = results%partBnk(i5)%linearMomX
             p5l(2) = results%partBnk(i5)%linearMomY
             p5l(3) = results%partBnk(i5)%linearMomZ
             p6l(1) = results%partBnk(i6)%linearMomX
             p6l(2) = results%partBnk(i6)%linearMomY
             p6l(3) = results%partBnk(i6)%linearMomZ
             es = e1 + e2 + e3 + e4 + e5 + e6
             if (es > 0) then
                v(1) = -(p1l(1) + p2l(1) + p3l(1) + p4l(1) + p5l(1) + p6l(1))/es
                v(2) = -(p1l(2) + p2l(2) + p3l(2) + p4l(2) + p5l(2) + p6l(2))/es
                v(3) = -(p1l(3) + p2l(3) + p3l(3) + p4l(3) + p5l(3) + p6l(3))/es
             else
                v(:) = 0.0d0
                write(coalObj%io%message, 2000) "605"
                call coalObj%io%print(4, 3, coalObj%io%message)
             end if
             call coalObj%kinema (p1l, v, p1s, ct1, st1, cf1, sf1, t1s, avg_mass)
             call coalObj%kinema (p2l, v, p2s, ct2, st2, cf2, sf2, t2s, avg_mass)
             call coalObj%kinema (p3l, v, p3s, ct3, st3, cf3, sf3, t3s, avg_mass)
             call coalObj%kinema (p4l, v, p4s, ct4, st4, cf4, sf4, t4s, avg_mass)
             call coalObj%kinema (p5l, v, p5s, ct5, st5, cf5, sf5, t5s, avg_mass)
             call coalObj%kinema (p6l, v, p6s, ct6, st6, cf6, sf6, t6s, avg_mass)
             if (t1s*(t1s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t2s*(t2s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t3s*(t3s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t4s*(t4s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t5s*(t5s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t6s*(t6s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
! Coalesced 6Li or 6He
             if ( (results%partBnk(i1)%charge + results%partBnk(i2)%charge + &
                  & results%partBnk(i3)%charge + results%partBnk(i4)%charge + &
                  & results%partBnk(i5)%charge + results%partBnk(i6)%charge) < 2.5) then
                ! Reduce amount of 6He, take only 1/he6Reduction [originally =4]
                if ( mod(dble(i2), he6Reduction) < 2.5) cycle

             end if
             numLi6 = numLi6 + 1
             if (numLi6 <= maxA6 ) then
                ili61(numLi6) = i1
                ili62(numLi6) = i2
                ili63(numLi6) = i3
                ili64(numLi6) = i4
                ili65(numLi6) = i5
                ili66(numLi6) = i6
                results%partBnk(i1)%coalesceNum = numLi6
                results%partBnk(i2)%coalesceNum = numLi6
                results%partBnk(i3)%coalesceNum = numLi6
                results%partBnk(i4)%coalesceNum = numLi6
                results%partBnk(i5)%coalesceNum = numLi6
                results%partBnk(i6)%coalesceNum = numLi6
                ia1(ia) = 0
                ia2(ia) = 0
                ia3(ia) = 0
                ia4(ia) = 0
                id1(id) = 0
                id2(id) = 0
             else
                write(coalObj%io%message, 1500) "Li6"
                call coalObj%io%print(1, 3, coalObj%io%message)
             end if
             exit
          end do ! numDeut loop
       end do ! numAlpha loop
       do it = 1, numTrit-1 ! Coalesce 6He or 6Li, t+t. t+He3
          if (it3(it) < 0.5) cycle      ! Check for t/3He already coalesced...
          i1 = it1(it)
          i2 = it2(it)
          i3 = it3(it)
          e1 = results%partBnk(i1)%kinEnergy + avg_mass
          e2 = results%partBnk(i2)%kinEnergy + avg_mass
          e3 = results%partBnk(i3)%kinEnergy + avg_mass
          p1l(1) = results%partBnk(i1)%linearMomX
          p1l(2) = results%partBnk(i1)%linearMomY
          p1l(3) = results%partBnk(i1)%linearMomZ
          p2l(1) = results%partBnk(i2)%linearMomX
          p2l(2) = results%partBnk(i2)%linearMomY
          p2l(3) = results%partBnk(i2)%linearMomZ
          p3l(1) = results%partBnk(i3)%linearMomX
          p3l(2) = results%partBnk(i3)%linearMomY
          p3l(3) = results%partBnk(i3)%linearMomZ
          do itt = it+1, numTrit
             if (it3(itt) < 0.5) cycle   ! Check for t/3He already coalesced...
             i4 = it1(itt)
             i5 = it2(itt)
             i6 = it3(itt)
             ! Check for coalesced 6Be and cycle
            if ( (results%partBnk(i1)%charge + results%partBnk(i2)%charge + &
                  & results%partBnk(i3)%charge + results%partBnk(i4)%charge + &
                  & results%partBnk(i5)%charge + results%partBnk(i6)%charge) &
                  & > 3.5) cycle
             e4 = results%partBnk(i4)%kinEnergy + avg_mass
             e5 = results%partBnk(i5)%kinEnergy + avg_mass
             e6 = results%partBnk(i6)%kinEnergy + avg_mass
             p4l(1) = results%partBnk(i4)%linearMomX
             p4l(2) = results%partBnk(i4)%linearMomY
             p4l(3) = results%partBnk(i4)%linearMomZ
             p5l(1) = results%partBnk(i5)%linearMomX
             p5l(2) = results%partBnk(i5)%linearMomY
             p5l(3) = results%partBnk(i5)%linearMomZ
             p6l(1) = results%partBnk(i6)%linearMomX
             p6l(2) = results%partBnk(i6)%linearMomY
             p6l(3) = results%partBnk(i6)%linearMomZ
             es = e1 + e2 + e3 + e4 + e5 + e6
             if (es > 0) then
                v(1) = -(p1l(1) + p2l(1) + p3l(1) + p4l(1) + p5l(1) + p6l(1))/es
                v(2) = -(p1l(2) + p2l(2) + p3l(2) + p4l(2) + p5l(2) + p6l(2))/es
                v(3) = -(p1l(3) + p2l(3) + p3l(3) + p4l(3) + p5l(3) + p6l(3))/es
             else
                v(:) = 0.0d0
                write(coalObj%io%message, 2000) "693"
                call coalObj%io%print(4, 3, coalObj%io%message)
             end if
             call coalObj%kinema (p1l, v, p1s, ct1, st1, cf1, sf1, t1s, avg_mass)
             call coalObj%kinema (p2l, v, p2s, ct2, st2, cf2, sf2, t2s, avg_mass)
             call coalObj%kinema (p3l, v, p3s, ct3, st3, cf3, sf3, t3s, avg_mass)
             call coalObj%kinema (p4l, v, p4s, ct4, st4, cf4, sf4, t4s, avg_mass)
             call coalObj%kinema (p5l, v, p5s, ct5, st5, cf5, sf5, t5s, avg_mass)
             call coalObj%kinema (p6l, v, p6s, ct6, st6, cf6, sf6, t6s, avg_mass)
             if (t1s*(t1s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t2s*(t2s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t3s*(t3s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t4s*(t4s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t5s*(t5s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
             if (t6s*(t6s + p0Factor) > coalObj%data%coalesRadiiLFragSqrd()) cycle
! Coalesced 6He or 6Li
             if ( (results%partBnk(i1)%charge + results%partBnk(i2)%charge + &
                  & results%partBnk(i3)%charge + results%partBnk(i4)%charge + &
                  & results%partBnk(i5)%charge + results%partBnk(i6)%charge) < 2.5) &
                  & then
                ! Reduce amount of 6He, take only 1/he6Reduction
                if (mod(dble(i2), he6Reduction) < 2.5) cycle
             end if
             numHe6 = numHe6 + 1
             if (numHe6 <= maxA6 ) then
                ihe61(numHe6) = i1
                ihe62(numHe6) = i2
                ihe63(numHe6) = i3
                ihe64(numHe6) = i4
                ihe65(numHe6) = i5
                ihe66(numHe6) = i6
                results%partBnk(i1)%coalesceNum = numHe6
                results%partBnk(i2)%coalesceNum = numHe6
                results%partBnk(i3)%coalesceNum = numHe6
                results%partBnk(i4)%coalesceNum = numHe6
                results%partBnk(i5)%coalesceNum = numHe6
                results%partBnk(i6)%coalesceNum = numHe6
                it1(it) = 0
                it2(it) = 0
                it3(it) = 0
                it1(itt) = 0
                it2(itt) = 0
                it3(itt) = 0
             else
                write(coalObj%io%message, 1500) "He6"
                call coalObj%io%print(1, 3, coalObj%io%message)
             end if
             exit
          end do ! numTrit loop
       end do ! numTrit loop

       do i = 1, numA7
          i1 = i71(i)
          i2 = i72(i)
          i3 = i73(i)
          i4 = i74(i)
          i5 = i75(i)
          i6 = i76(i)
          i7 = i77(i)
          ind(1) = i1
          ind(2) = i2
          ind(3) = i3
          ind(4) = i4
          ind(5) = i5
          ind(6) = i6
          ind(7) = i7
          call coalObj%codir( results, ind, 7)
          results%partBnk(i1)%charge = results%partBnk(i1)%charge + &
               & results%partBnk(i2)%charge + results%partBnk(i3)%charge + &
               & results%partBnk(i4)%charge + results%partBnk(i5)%charge + &
               results%partBnk(i6)%charge + results%partBnk(i7)%charge
          results%partBnk(i1)%coalesceNum = 0
          results%partBnk(i1)%numBaryons = 7
       end do
       do i = 1, numLi6
          i1 = ili61(i)
          i2 = ili62(i)
          i3 = ili63(i)
          i4 = ili64(i)
          i5 = ili65(i)
          i6 = ili66(i)
          ind(1) = i1
          ind(2) = i2
          ind(3) = i3
          ind(4) = i4
          ind(5) = i5
          ind(6) = i6
          call coalObj%codir( results, ind, 6)
          results%partBnk(i1)%charge = results%partBnk(i1)%charge + &
               & results%partBnk(i2)%charge + results%partBnk(i3)%charge + &
               & results%partBnk(i4)%charge + results%partBnk(i5)%charge + &
               & results%partBnk(i6)%charge
          results%partBnk(i1)%coalesceNum = 0
          results%partBnk(i1)%numBaryons = 6
       end do
       do i = 1, numHe6
          i1 = ihe61(i)
          i2 = ihe62(i)
          i3 = ihe63(i)
          i4 = ihe64(i)
          i5 = ihe65(i)
          i6 = ihe66(i)
          ind(1) = i1
          ind(2) = i2
          ind(3) = i3
          ind(4) = i4
          ind(5) = i5
          ind(6) = i6
          call coalObj%codir( results, ind, 6)
          results%partBnk(i1)%charge = results%partBnk(i1)%charge + &
               & results%partBnk(i2)%charge + results%partBnk(i3)%charge + &
               & results%partBnk(i4)%charge + results%partBnk(i5)%charge + &
               & results%partBnk(i6)%charge
          results%partBnk(i1)%coalesceNum = 0
          results%partBnk(i1)%numBaryons = 6
       end do
    end if
! end expanded coalescence

! Coalesce remaining flagged d, t/He3, and He4
    if (numAlpha > 0) then
       ! Coalesce all alpha fragments
       do ia = 1,numAlpha
          if (ia1(ia) > 0) then
             i1 = ia1(ia)
             i2 = ia2(ia)
             i3 = ia3(ia)
             i4 = ia4(ia)
             ind(1) = i1
             ind(2) = i2
             ind(3) = i3
             ind(4) = i4
             call coalObj%codir( results, ind, 4)
             results%partBnk(i1)%charge = 2
             results%partBnk(i1)%coalesceNum = 0
             results%partBnk(i1)%numBaryons = 4
          end if
       end do
    endif
    if (numTrit /= 0) then
! --------------------------------------
       ! Coalesce all tritium fragments
       do it = 1,numTrit
          if (it1(it) > 0) then
             i1 = it1(it)
             i2 = it2(it)
             i3 = it3(it)
             ind(1) = i1
             ind(2) = i2
             ind(3) = i3
             call coalObj%codir( results, ind, 3)
             results%partBnk(i1)%charge = results%partBnk(i1)%charge + &
                  & results%partBnk(i2)%charge + results%partBnk(i3)%charge
             results%partBnk(i1)%coalesceNum = 0
             results%partBnk(i1)%numBaryons = 3
          endif
       end do
    endif
! --------------------------------------
    do id = 1,numDeut
       ! Coalesce all deuterium fragments
       if (id1(id) > 0) then
          i1 = id1(id)
          i2 = id2(id)
          if ((results%partBnk(i1)%charge + results%partBnk(i2)%charge) == 1) then
             ind(1) = i1
             ind(2) = i2
             call coalObj%codir( results, ind, 2)
             results%partBnk(i1)%charge = 1
             results%partBnk(i1)%coalesceNum = 0
             results%partBnk(i1)%numBaryons = 2
          else
             results%partBnk(i1)%coalesceNum = 0
             results%partBnk(i2)%coalesceNum = 0
          endif
       endif
    end do

! Done coalescing particles; shift reminaing nucleons down
    i = 1
130 if (results%partBnk(i)%coalesceNum == 0) then
       ! Particle did not coalesce; look at next particle
       if (i >= results%numParticles) go to 140 ! Reached end of particle list, stop checking
       i = i + 1
       go to 130
    endif
    ! Found a particle that was coalesced earlier, shift top particles down
    results%partBnk(i)%linearMomX   = results%partBnk(results%numParticles)%linearMomX
    results%partBnk(i)%linearMomY   = results%partBnk(results%numParticles)%linearMomY
    results%partBnk(i)%linearMomZ   = results%partBnk(results%numParticles)%linearMomZ
    results%partBnk(i)%coalesceFlag = results%partBnk(results%numParticles)%coalesceFlag
    results%partBnk(i)%kinEnergy    = results%partBnk(results%numParticles)%kinEnergy
    results%partBnk(i)%restMass     = results%partBnk(results%numParticles)%restMass
    results%partBnk(i)%charge       = results%partBnk(results%numParticles)%charge
    results%partBnk(i)%coalesceNum  = results%partBnk(results%numParticles)%coalesceNum
    results%partBnk(i)%strangeness  = results%partBnk(results%numParticles)%strangeness
    results%partBnk(i)%numBaryons   = results%partBnk(results%numParticles)%numBaryons
    results%numParticles = results%numParticles - 1
    if (i <= results%numParticles) go to 130
140 continue
150 continue

    ! All particles coalesced;
    ! 'Reset' portion of array that was emptied from coalesced particles
    do i = (results%numParticles + 1), results%numParticles
       results%partBnk(i)%linearMomX   = zro
       results%partBnk(i)%linearMomY   = zro
       results%partBnk(i)%linearMomZ   = zro
       results%partBnk(i)%coalesceFlag = zro
       results%partBnk(i)%kinEnergy    = zro
       results%partBnk(i)%restMass     = zro
       results%partBnk(i)%charge       = zro
       results%partBnk(i)%coalesceNum  = zro
       results%partBnk(i)%strangeness  = zro
       results%partBnk(i)%numBaryons   = zro
    end do

    ! Set number of "new" fragments (those created from coalescence)
    results%numFormedFragments = results%numCoalesced - &
         & ( results%numParticles - results%numParticles )

    return

! ======================================================================
1500 format("More ", A, " particle(s) were created due to ", &
          & "coalescence than can be stored in memory. Coalescence of ", &
          & "these particles will no longer be considered.")
2000 format("Divide by zero error prevented in ", &
          & "'coalesl.f90', line(s) ", A)
2100 format("Square root error prevented in ", &
          & "'coalesl.f90', line(s) ", A)
! ======================================================================

  end subroutine coalesl


module model_initialiser

contains

   ! remesher:
   ! Function based on the origianl REMESH function
   ! Input (in COMMON blocks):
   !  H(,) - array of independent variables (in unnamed COMMON)
   !  DH(,) - list of changes in independent variables (in unnamed COMMON)
   !  KH - current number of meshpoints in H(,)
   ! Input options:
   !  KH2 - new number of meshpoints for this model
   !  JCH - switch to determine whether to construct new mesh spacing function
   !        and initialise composition or not.
   !  BMS - Total mass in the binary (EV)
   !  TM  - New mass of the star
   !  P1  - New rotational period of the star (solid body)
   !  ECC - New eccentricity of the binary
   !  OA  - New orbital angular momentum
   !  JSTAR - Labels which if the stars to initislise variables for
   !  JF - Switch to decide which variables to recompute
   ! TODO: this could be split up into different subroutines for each of the
   ! individual tasks.
   subroutine remesher( kh2, jch, bms, tm, p1, ecc, oa, jstar, jf )
      use real_kind
      use constants
      use mesh
      use init_dat
      use settings
      use control
      use atomic_data
      use test_variables
      use eostate_types
      use structure_functions
      use current_model_properties
      use structure_variables
      use accretion_abundances
      use indices

      implicit none
      integer, intent(in) :: kh2, jch, jstar, jf
      real(double), intent(in) :: bms, tm, p1, ecc, oa
      integer :: nm_current, nm_next, nm_target
      integer :: ik, ikk, ih, i
      integer :: jo
      integer :: ksv, kt5
      type(init_dat_settings) :: initdat
      real(double) :: nh(nvar,nm), ndh(nvar,nm), nndh(nvar,nm)
      real(double) :: q1, q2, dk, dty, vd, dtb, ageb, pcrit, wcrit, w1
      real(double) :: si, vma, hpc
      logical :: equilibrium
      logical :: newmesh
      real(double) :: var(nvar), dvar(nvar), fn1(nfunc)
      real(double) :: qa(NM)
      type(eostate) :: eos

      real(double) :: xh0, xhe0, xc0, xn0, xo0, xne0, xmg0, xsi0, xfe0
      real(double) :: che
      real(double) :: xh, xhe, xc, xn, xo, xne, xmg, xsi, xfe
      real(double) :: r

      real(double) :: qq            ! Determines mesh-point metric: mesh-point interval
      real(double) :: qm            ! Determines mesh-point metric: derivative of mesh spacing function wrt mass
      real(double) :: phim          ! Derivative of gravitational potential with respect to m**(2/3)
      real(double) :: gmr           ! Effective gravity at the surface(?)
      real(double) :: m3            ! m^(1/3), m is the mass coordinate

      ! Backup current settings so we can restore them when we're done
      dtb = dt
      ageb = age
      call push_init_dat(initdat, kh2, ksv, kt5, jch)
      ! Change settings to a reasonable set of defaults
      call load_basic_init_dat(ik, ksv, kt5, ik)
      kop = initdat%kop
      kx = 0; ky = 0; kz = 0; kth = 0
      cmi = 0.0
      crd = 0.0d0
      kt1 = 100
      kt2 = 0
      kt3 = 0
      kt4 = 100
      kt5 = 100
      ksv = 100
      joc = 1
      jter = 0

      ! Set initial composition.
      ! The composition variables are NOT the actual mass fractions if we
      ! use non-integer atomic masses, so we have to compute what they are
      ! The composition variables used in the code are baryon number fractions
      ! We calculate this even if we don't want to do a ZAMS run because we need to
      ! know the baryon number densities of Fe, Si and Mg.
      ! Note that the actual abundances of Si and Fe are forced to by non-zero.
      ! This is because the EoS becomes poorly defined if there are not enough free
      ! electrons. It has no impact on the opacity and only a small impact on the
      ! mean molecular weight and the mass loss rate.
      che = 1.0d0 - ch - czs
      cn = 1.0d0 - cc - co - cne - cmg - csi - cfe

      xh0 = ch*cbn(1)/can(1)
      xhe0 = che*cbn(2)/can(2)
      xc0 = cc*czs*cbn(3)/can(3)
      xn0 = cn*czs*cbn(4)/can(4)
      xo0 = co*czs*cbn(5)/can(5)
      xne0 = cne*czs*cbn(6)/can(6)
      xmg0 = cmg*czs*cbn(7)/can(7)
      xsi0 = csi*czs*cbn(8)/can(8)
      xfe0 = cfe*czs*cbn(9)/can(9)

      xh = xh0
      xhe = xhe0
      xc = xc0
      xn = xn0
      xo = xo0
      xne = xne0
      xmg = xmg0
      xsi = max(xsi0, csi*1.0d-4)
      xfe = max(xfe0, cfe*1.0d-4)

      vma = xh + xhe + xc + xn + xo + xne + xmg + xsi + xfe
      xh = xh / vma
      xhe = xhe / vma
      xc = xc / vma
      xn = xn / vma
      xo = xo / vma
      xne = xne / vma
      xfe = xfe / vma
      xsi = xsi / vma
      xmg = xmg / vma

      ! Initialise composition variables
      h(VAR_MG24, 1:kh) = xmg
      h(VAR_SI28, 1:kh) = xsi
      h(VAR_FE56, 1:kh) = xfe
      if ( jch >= 4 ) then
         h(VAR_H1,1:kh) = xh
         h(VAR_O16,1:kh) = xo
         h(VAR_HE4,1:kh) = xhe
         h(VAR_C12,1:kh) = xc
         h(VAR_NE20,1:kh) = xne
         h(VAR_N14,1:kh) = xn
      end if
      ! We should always do this for Mg24, since that's never stored
      if (use_mg24_eqn) then
         do ik=1, kh
            xmg = h(VAR_H1,ik) + h(VAR_HE4, ik) + h(VAR_C12, ik) + h(VAR_O16, ik) + h(VAR_NE20, ik) + h(VAR_N14, ik) + xfe + xsi
            h(VAR_MG24,ik) = max(0.0d0, 1.0 - xmg)
         end do
      end if

      ! Now we must also convert the abundances of the accreted material. If not
      ! set from init.dat, set from initial abundances.
      !> \todo FIXME: this will cause problems if we ever need to call REMESH twice in
      !! the same run
      !<
      x1ac = x1ac*cbn(1)/can(1)
      x4ac = x4ac*cbn(2)/can(2)
      x12ac = x12ac*cbn(3)/can(3)
      x14ac = x14ac*cbn(4)/can(4)
      x16ac = x16ac*cbn(5)/can(5)
      x20ac = x20ac*cbn(6)/can(6)
      x24ac = x24ac*cbn(7)/can(7)
      if (x1ac < 0.0) x1ac = xh0
      if (x4ac < 0.0) x4ac = xhe0
      if (x12ac < 0.0) x12ac = xc0
      if (x14ac < 0.0) x14ac = xn0
      if (x16ac < 0.0) x16ac = xo0
      if (x20ac < 0.0) x20ac = xne0
      if (x24ac < 0.0) x24ac = xmg0
      vma = x1ac + x4ac + x12ac + x14ac + x16ac + x20ac + x24ac + xfe + xsi

      x1ac  = x1ac  / vma
      x4ac  = x4ac  / vma
      x12ac = x12ac / vma
      x14ac = x14ac / vma
      x16ac = x16ac / vma
      x20ac = x20ac / vma
      x24ac = x24ac / vma
      ! make sure XH is 1-everything else and abundancies sum to 1
      x1ac = max(0.0d0, 1.0d0-(x4ac+x12ac+x14ac+x16ac+x20ac+x24ac+xfe0+xsi0))

      ! Initialise accretion abundances for both stars
      xac(1, 1:2) = x1ac
      xac(2, 1:2) = x4ac
      xac(3, 1:2) = x12ac
      xac(4, 1:2) = x14ac
      xac(5, 1:2) = x16ac
      xac(6, 1:2) = x20ac
      xac(7, 1:2) = x24ac

      ! Set initial values of some other variables
      ! Typical mass-scale for the interior (needed for mesh spacing function)
      mc(jstar) = tm          ! New mass after remesh
      var(:) = h(:, kh)
      dvar(:) = 0.0d0
      call funcs1 ( kh, -2, var(:), dvar(:), fn1(:), eos, px=sx(:,2))
      hpc = sqrt(eos%p/(cg * eos%rho * eos%rho))
      mc(jstar) = 3.5d-33 * eos%rho * hpc**3

      ! Initialise binary (orbital) parameters
      h(VAR_HORB, 1:kh) = oa                             ! New orbital angular momentum
      h(VAR_ECC, 1:kh) = ecc                             ! New eccentricity
      h(VAR_BMASS, 1:kh) = bms                           ! New total binary mass

      ! First: change the number of meshpoints or the mesh spacing function
      ! Determine if we need to calculate a new mesh (independent of the number
      ! of meshpoints)
      newmesh = .false.
      if (jch>3) newmesh = .true.
      ! Set new number of meshpoints
      nm_current = kh
      nm_target = kh2
      nm_next = nm_target
      print *, 'nremesh from', nm_current, 'to', nm_target
      do while(newmesh .or. nm_current /= nm_next)
         newmesh = .false.
         print *, 'trying ', nm_next
         ! Store old model, so we can go back if needed
         nh(:,1:nm_current) = h(:,1:nm_current)
         ndh(:,1:nm_current) = dh(:,1:nm_current)
         ! Find values of mesh spacing function
         do ik=1, nm_current
            var(:) = h(:, ik)
            call funcs1 ( ik, -2, var(:), dvar(:), fn1(:))                 ! Calculate stuff
            qa(ik) = qq                            ! Store mesh spacing function
         end do
         ! Interpolate model onto new mesh
         ! Find values of mesh spacing function at the external points
         ! Needed to calculate the new mesh, where the meshspacing gradient is
         ! constant.
         q1 = qa(1)
         q2 = (nm_next - 1.0d0)/(qa(nm_current) - qa(1))
         do ik = 1, nm_current
            qa(ik) = (qa(ik) - q1)*q2 + 1.0d0   ! Adjust meshspacing
         end do
         ih = 1
         do ik = 1, nm_next
            dk = 0.0d0
            if ( ik == nm_next ) ih = nm_current
            if ( ik /= 1 .and. ik /= nm_next ) then
               ! Find the proper value for the meshspacing function at
               ! this meshpoint
               do i = 1, 50
                  ! Sanity check: abort if we're running out of the mesh
                  ! boundary
                  if ( ih+1 > nm_current) then
                     write (0, *) &
                          'remesh running outside mesh boundary, aborting'
                     stop
                  end if
                  if ( ik >= qa(ih + 1) ) ih = ih + 1
                  if ( ik < qa(ih + 1) ) exit   ! Break loop
               end do
               dk = (ik - qa(ih))/(qa(ih + 1) - qa(ih))
            end if
            ! Linear interpolation for new H and DH
            h(:, ik) = nh(:, ih) + dk*(nh(:, ih + 1) - nh(:, ih))
            nndh(:, ik) = ndh(:, ih) + dk*(ndh(:, ih + 1) - ndh(:, ih))
         end do
         !H(6, 1:KH) = 1.0/Q2              ! Gradient of mesh spacing

         ! Now see if the model will converge properly if we let the code iterate
         dty = dt/csy
         jo = 0
         jnn = 0
         kh = nm_next
         call printb ( jo, 1, 22 )
         age = age - dty
         call nextdt ( dty, jo, 22 )
         jnn = 1
         dh(:, 1:nm_next) = 0.0d0
         call solver(20, id, kt5, jo)
         if (jo == 0) then
            print *, 'converged ok'
            ! If yes, pick next number of meshpoints
            nm_current = nm_next
            nm_next = nm_target
            h(:,1:nm_current) = h(:,1:nm_current) + dh(:,1:nm_current)
         else
            ! If no, pick a smaller number of meshpoints in between the current value
            ! and the target and try again.
            nm_next = (nm_current+nm_next)/2
            print *, 'cannot converge, reduce to ', nm_next
            ! Restore backup copies of H and DH
            h(:,1:nm_current) = nh(:,1:nm_current)
            dh(:,1:nm_current) = ndh(:,1:nm_current)
         end if
      end do
      print *, 'nremesh finished with ', nm_current, '(wanted ', nm_target,')'
      if (nm_current < nm_target) then
         print *, '*** nremesh failed ***'
         stop
      end if
      dh(:, 1:nm_current) = nndh(:,1:nm_current)
      dh(:, 1:nm_current) = 0.0
      kh = nm_current

      ! Second: scale the mass
      vd = tm/h(VAR_MASS, 1)
      vd = 1.0
      print *, 'scaling mass by factor', vd
      do while (abs(1.0d0 - vd) > 0.1)
         vd = max(0.9d0,min(vd, 1.1d0))
         h(VAR_MASS, 1:kh) = vd*h(VAR_MASS, 1:kh)       ! Scale mass

         kth = 1
         jhold = 4
         equilibrium = equilibrate_model(kt5)
         if (.not. equilibrium) then !H(:,1:nm_current) = NH(:,1:nm_current)
            print *, '*** failed ***'
            stop
         end if

         vd = tm/h(VAR_MASS, 1)
      end do
      h(VAR_MASS, 1:kh) = vd*h(VAR_MASS, 1:kh)          ! Scale mass

      ! Third: scale the surface rotation rate
      ! Make the whole star rotate with the surface rate, if desired
      ! Convert rotational period -> rotation rate
      forall (ik=1:kh) h(VAR_OMEGA, ik) = 2.0*cpi/(h(VAR_OMEGA, ik) * csday)
      if (start_with_rigid_rotation) h(VAR_OMEGA,2:kh) = h(VAR_OMEGA,1)
      ! Now scale the surface rate, similar to the way the mass is scaled
      ! If we forced the star to rigid rotation before then this will set the
      ! rotation profile throughout the entire star
      wcrit = sqrt(cg*tm/exp(3*h(VAR_LNR, 1)))
      pcrit = 2.0*cpi/wcrit/csday
      w1 = 2.0*cpi/p1/csday
      print *, 'scaling rotation rate by factor', w1/h(13, 1)
      ! For rotation rates within 1/4 of critical be a bit more careful. Here we
      ! need to approach the desired rate smoothly, adjusting the structure of
      ! the star at each step.
      !> \todo FIXME: This should be more akin to the bit that updates the code on the
      !! new mesh, ie, not necessarily bring the star into equilibrium.
      !<
      if (wcrit/w1 < 4.0) then
         call set_solid_rotation
         print *, 'Period', p1, 'close to critical rate', pcrit
         vd = 0.25*wcrit/h(VAR_OMEGA,1)
         h(VAR_OMEGA, 1:kh) = vd*h(VAR_OMEGA, 1:kh)     ! Scale rotation rate
         kth = 1
         equilibrium = converge_model(kt5)
         do while (equilibrium .and. abs(w1 - h(VAR_OMEGA,1)) > 1.0d-6)
            vd = max(0.9d0,min(vd, 1.1d0))
            h(VAR_OMEGA, 1:kh) = vd*h(VAR_OMEGA, 1:kh)
            jhold = 4
            equilibrium = converge_model(kt5)
            vd = w1/h(VAR_OMEGA, 1)
            if (.not. equilibrium) then
               print *, '*** failed ***'
               stop
            end if
         end do
      end if
      vd = w1/h(VAR_OMEGA, 1)
      h(VAR_OMEGA, 1:kh) = vd*h(VAR_OMEGA, 1:kh)        ! Scale rotational period

      ! Compute moment of inertia and surface potential
      if (jf /= 2) then
         q2 = h(VAR_QK,1)
         h(VAR_QK, 1:kh) = 1.0d0
         h(VAR_INERT, 1:kh) = 1.0d0              ! Moment of Inertia
         h(VAR_PHI, 1:kh) = 0.0d0              ! Gravitational potential
         do ik = 2, kh
            ikk = kh + 2 - ik
            var(:) = h(:, ik)
            call funcs1 ( ik, -2, var(:), dvar(:), fn1(:), px=sx(:,ikk))
            qq = sx(85, ikk)
            qm = sx(86, ikk)
            phim = sx(87, ikk)
            m3 = sx(89, ikk)

            r = sqrt(abs(exp(2.0d0*var(7)) - ct(8)))
            h(VAR_INERT, ik) = h(VAR_INERT, ik - 1) + r*r*m3/(abs(qm))
            h(VAR_PHI, ik) = h(VAR_PHI, ik - 1) + phim/abs(qm)
         end do
         gmr = sx(88, kh+1)
         h(VAR_QK, 1:kh) = q2
         h(VAR_PHIS, 1:kh) = - gmr              ! Potential at the stellar surface
         si = h(VAR_INERT, kh)                   ! Total moment of inertia

         do ik = 1, kh
            h(VAR_INERT, ik) = (si - h(VAR_INERT, ik))*abs(q2)  ! Moment of inertia of interior
            h(VAR_PHI, ik) = - gmr - h(VAR_PHI, ik)*abs(q2) ! Gravitational potential
         end do
      end if
      ! Total angular momentum integration
      h(VAR_TAM, 1:kh) = h(VAR_INERT, 1:kh)*h(VAR_OMEGA, 1)

      if (relax_loaded_model) then
         kth = 1
         jhold = 4
         print *, 'equilibrating...'
         equilibrium = equilibrate_model(kt5)
         if (.not. equilibrium) then
            print *, '*** failed ***'
            stop
         end if
         print *, 'done'
         dh(:, 1:kh) = 0.0
      end if

      ! Restore old init.dat
      call pop_init_dat(initdat, ik, ksv, kt5, ik)
      dt = dtb
      age = ageb

      print *, 'Remesh done'
   end subroutine remesher

   function converge_model(kt5)
      use real_kind
      use mesh
      use constants
      use test_variables

      implicit none
      logical :: converge_model
      integer, intent(in) :: kt5
      real(double) :: dty
      integer :: jo

      jo = 0
      dty = dt/csy
      call solver(20, id, kt5, jo)
      if (jo == 0) then
         age = 0.0d0
         call printb ( jo, 1, 22 )
         h(:,1:kh) = h(:,1:kh) + dh(:,1:kh)
         call nextdt ( dty, jo, 22 )
      end if
      converge_model = (jo == 0)

   end function converge_model

   function equilibrate_model(kt5)
      use real_kind
      use mesh
      use constants
      use test_variables

      implicit none
      logical :: equilibrate_model
      integer, intent(in) :: kt5
      real(double) :: dty
      integer :: i, jo

      jo = 0
      do i=1, 40
         dty = dt/csy
         call solver(20, id, kt5, jo)
         if (jo /= 0) exit
         age = 0.0d0
         call printb ( jo, 1, 22 )
         h(:,1:kh) = h(:,1:kh) + dh(:,1:kh)
         call nextdt ( dty, jo, 22 )
         if (abs(lth) < 1.0d-8 .or. lth < 0.0d0) exit
      end do
      equilibrate_model = .false.
      if (lth < 1.0d-6 .and. jo == 0) equilibrate_model = .true.

   end function equilibrate_model

end module model_initialiser


! <rlsrcs.f90 - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a
!*    simplified EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*****************************************************************************!

      subroutine RLSRCS

! The subroutine reads static line sources data from file.
! ----------------------------------------------------------------------------------
! Based on:
! Version Episode 5.5 (May29, 2012) prepared for BB-Stand-Alone
! Original source code of EPISODE by Sam-Erik Walker (NILU)
!
! Sam-Erik Walker
! Norwegian Institute for Air Research (NILU)
! Instituttveien 18 P.O. Box 100
! N-2027 Kjeller, NORWAY
! Tel: +47 63898000 Fax: +47 63898050
! E-mail: sam-erik.walker@nilu.no
!
! ----------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------
! REVISION HISTORY
!
!           2016  M. Karl: modified handling of the line source emission reading
!                          Width of road QLW set to 2 times (lane) width WV
!
! ----------------------------------------------------------------------------------

      use mod_util
      use mod_main
      use mod_site
      use mod_time
      use mod_mete
      use mod_conc
      use mod_depo
      use mod_lsrc

      implicit none

! Local variables

      real :: RDV
      real :: RMAXV
      real :: RMINV
      real :: W1V
      real :: W2V
      real :: X1V
      real :: X2V
      real :: Y1V
      real :: Y2V
      real :: Z1V
      real :: Z2V
      integer :: IQL
      integer :: IQLV
      logical :: LEOF
!MSK start
      real :: WV
      character(len=50) :: COMMENT
      integer :: QLRIV
!MSK end

! RDV   - Receptor distance
! RMAXV - Receptor maximum distance
! RMINV - Receptor minimum distance
! W1V   - Line source width lane 1
! W2V   - Line source width lane 2
! X1V   - Line source start point x-coordinate
! X2V   - Line source end   point x-coordinate
! Y1V   - Line source start point y-coordinate
! Y2V   - Line source end   point y-coordinate
! Z1V   - Line source start point z-coordinate
! Z2V   - Line source end   point z-coordinate
! IQL   - Line source index
! IQLV  - Line source index
! LEOF  - If end of file then true else false

! Define number of line source lanes

!MSK start
!MSK line source emission files contain only data for one lane
!MSK assume that second lane has same emission as first lane
      NQLL = 2
      MQLL = 2

! Open file
      CALL OPIFIL(LSRSFN,LSRSUN,LSRSFE,LSRSFM)

! Check if file exists

      IF (LSRSFE) THEN

! Read static line sources data

          IQL = 0

!MSK start
!MSK first readin needed to calculate NQL based on the dynamic line source data
!          CALL NXTDAT(LSRSUN,LEOF)
!MSK this reads the line source metadata file
!MSK 8 comment lines
          READ (LSRSUN,*,END=199) COMMENT
          READ (LSRSUN,*,END=199) COMMENT
          READ (LSRSUN,*,END=199) COMMENT
          READ (LSRSUN,*,END=199) COMMENT

          READ (LSRSUN,*,END=199) COMMENT
          READ (LSRSUN,*,END=199) COMMENT
          READ (LSRSUN,*,END=199) COMMENT
          READ (LSRSUN,*,END=199) COMMENT

  100     CONTINUE

! new format of metadata
!  IQLV   X1V    X2V     Y1V     Y2V     Z1V     Z2V      WV   RMAXV   INDICES
!
!MSK          READ (LSRSUN,*,END = 199) IQLV,X1V,Y1V,Z1V,X2V,Y2V,Z2V,       &
!MSK                                   W1V,W2V,RMINV,RMAXV,RDV

          READ (LSRSUN,*,END = 199) IQLV, X1V, X2V, Y1V, Y2V, Z1V, Z2V,     &
                                    WV, RMAXV, QLRIV

!MSK end

          IQL = IQL + 1

! Goto next line source

          GOTO 100

  199     CONTINUE

! Define total number of line sources

          NQL = IQL

          IF (NQL .GT. 0) THEN

              IF (.NOT. ALLOCATED(QL))        ALLOCATE(QL(NC,NQL,NQLL))
              IF (.NOT. ALLOCATED(QLL))       ALLOCATE(QLL(NQL))
              IF (.NOT. ALLOCATED(QLRMAX))    ALLOCATE(QLRMAX(NQL))
              IF (.NOT. ALLOCATED(QLRMIN))    ALLOCATE(QLRMIN(NQL))
              IF (.NOT. ALLOCATED(QLSW0))     ALLOCATE(QLSW0(NQL))
              IF (.NOT. ALLOCATED(QLWREDFAC)) ALLOCATE(QLWREDFAC(NQL))
              IF (.NOT. ALLOCATED(QLX))       ALLOCATE(QLX(NQL,2))
              IF (.NOT. ALLOCATED(QLY))       ALLOCATE(QLY(NQL,2))
              IF (.NOT. ALLOCATED(QLZ))       ALLOCATE(QLZ(NQL,2))
              IF (.NOT. ALLOCATED(QLW))       ALLOCATE(QLW(NQL))
              IF (.NOT. ALLOCATED(QLTMAX))    ALLOCATE(QLTMAX(NQL))
!MSK start
              IF (.NOT. ALLOCATED(QLRI))       ALLOCATE(QLRI(NQL))
!MSK: to allocate only after NRL is calculated in clsrcs.for
!              IF (.NOT. ALLOCATED(CRL))       ALLOCATE(CRL(NC,2*NQL))
!              IF (.NOT. ALLOCATED(DDEPRL))    ALLOCATE(DDEPRL(NC,2*NQL))
!              IF (.NOT. ALLOCATED(WDEPRL))    ALLOCATE(WDEPRL(NC,2*NQL))
              IF (.NOT. ALLOCATED(QLRD))      ALLOCATE(QLRD(2*NQL))
              IF (.NOT. ALLOCATED(XRL))       ALLOCATE(XRL(2*NQL))
              IF (.NOT. ALLOCATED(YRL))       ALLOCATE(YRL(2*NQL))
              IF (.NOT. ALLOCATED(ZRL))       ALLOCATE(ZRL(2*NQL))
!MSK end

          ENDIF

          MQL = NQL

! Rewind file

          REWIND (LSRSUN)

! Read static line sources data again

          IQL = 0

!MSK start
!          CALL NXTDAT(LSRSUN,LEOF)
!MSK 8 comment lines
          READ (LSRSUN,*,END=999) COMMENT
          READ (LSRSUN,*,END=999) COMMENT
          READ (LSRSUN,*,END=999) COMMENT
          READ (LSRSUN,*,END=999) COMMENT

          READ (LSRSUN,*,END=999) COMMENT
          READ (LSRSUN,*,END=999) COMMENT
          READ (LSRSUN,*,END=999) COMMENT
          READ (LSRSUN,*,END=999) COMMENT

  200     CONTINUE

! new format of metadata
!  IQLV   X1V    X2V     Y1V     Y2V     Z1V     Z2V      WV   RMAXV   INDICES
!
!MSK          READ (LSRSUN,*,END = 999) IQLV,X1V,Y1V,Z1V,X2V,Y2V,Z2V,       &
!MSK                                   W1V,W2V,RMINV,RMAXV,RDV

          READ (LSRSUN,*,END = 999) IQLV, X1V, X2V, Y1V, Y2V, Z1V, Z2V,     &
                                    WV, RMAXV, QLRIV

          IQL = IQL + 1

! Start and end coordinates of the line source

          QLX(IQL,1) = X1V
          QLY(IQL,1) = Y1V
          QLZ(IQL,1) = Z1V
          QLX(IQL,2) = X2V
          QLY(IQL,2) = Y2V
          QLZ(IQL,2) = Z2V

! Define width and influence sone for the line source

!MSK start

! Width of road QLW
!
!MSK          QLW(IQL)    = W1V + W2V
!MSK          QLW(IQL)    = WV !guess
          QLW(IQL)    = 2.*WV
!MSK          QLRMIN(IQL) = RMINV

! Absolute maximum value for the "maximum influence distance" (in meters) QLRMAX
!
!MSK start: Maximum influence distance should not be greater than DX/2
!MSK          QLRMAX(IQL) = RMAXV
!MSK          QLRMAX(IQL) = min(RMAXV, 500.)
          QLRMAX(IQL) = min(RMAXV, DX/2.)

! Create two receptor points on each side of the line source
!
!MSK: unfortunately RDV is not in the Metadata
!MSK          QLRD(2*IQL-1) = RDV
!MSK          QLRD(2*IQL  ) = RDV
!
! Line source index
          QLRI(IQL)   = QLRIV

! Minimum distance from receptor to road side QLRMIN
!
!MSK copied from below, value from LHS
!MSK          QLRMIN(IQL) = 10.
!MSK use value for Transphorm from BDE:
          QLRMIN(IQL) = 5.

! Distance from road side to line source associated receptor point:
!
          IF (QLRI(IQL) .GT. 0) THEN
!MSK: qlridist = 40.0 m, value from LHS
!MSK use value of 20.0 m for Transphorm from BDE
              QLRD(2*IQL - 1) = QLW(IQL)/2. + 20.
              QLRD(2*IQL    ) = QLW(IQL)/2. + 20.
          ELSE
              QLRD(2*IQL - 1) = MISS
              QLRD(2*IQL    ) = MISS
          ENDIF
!MSK end

! Goto next line source

          GOTO 200

  999     CONTINUE

          print *,'rlsrcs: finished second reading of metadata'

          IF (MESSFE) WRITE (MESSUN,2000) NQL

      ELSE

          print *,'RLSRCS: No Line Source emission metadata file provided. Stopped'
          stop

      ENDIF

! Close file

      CALL CLIFIL(LSRSFN,LSRSUN,LSRSFE,LSRSFM)

      RETURN

! Formats

 1000 format(A256)

 2000 format('RLSRCS: Read static data for ',I5,' line source(s)')
 2010 format('RLSRCS: No line sources metadata!')

! End of subroutine RLSRCS

      end subroutine rlsrcs


	SUBROUTINE OA_WGRD  ( gdattm, ngrid, parm, level,
     +			      ivcord, grid, kex, key, iextnd, iret )
C************************************************************************
C* OA_WGRD								*
C*									*
C* This subroutine writes grids computed in an objective analysis to	*
C* the grid file.  Although the data in GRID have been computed for the	*
C* extend area, only the data in the grid area are written to the file.	*
C*									*
C* OA_WGRD ( GDATTM, NGRID, PARM, LEVEL, IVCORD, GRID, KEX, KEY,	*
C*           IEXTND, IRET )						*
C*									*
C* Input parameters:							*
C*	GDATTM		CHAR*		Date/time for grids		*
C*	NGRID		INTEGER		Number of grids			*
C*	PARM   (NGRID)	CHAR*		Parameters			*
C*	LEVEL  (NGRID)	INTEGER		Levels				*
C*	IVCORD (NGRID)	INTEGER		Vertical coordinate		*
C*	GRID		REAL		Grid data			*
C*	 (NGRID,KEX,KEY)						*
C*	KEX		INTEGER		X points in extend area		*
C*	KEY		INTEGER		Y points in extend area		*
C*	IEXTND (4)	INTEGER		Grid extension			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 7/86						*
C* M. desJardins/GSFC	 7/87	Added new GD calls for GEMPAK4		*
C* M. desJardins/GSFC	11/88	GEMPAK 4.1				*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* T. Piper/SAIC	 1/02	Set correct length for ighdr		*
C* R. Tian/SAIC		 5/02	Removed IGDFLN, changed to call DG_NWDT	*
C* T. Lee/SAIC		12/05	Initialized ighdr			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid ( NGRID, KEX, KEY )
	CHARACTER*(*)	parm (*), gdattm
	INTEGER		level (*), iextnd (*), ivcord (*)
C*
	CHARACTER	gtime (2)*20, gparm*12, gpack*12
	INTEGER		levelg (2), ighdr (LLGDHD)
C*
	REAL		gwork (LLMXGD)
C*
	DATA		gpack / ' ' /
C*
C------------------------------------------------------------------------
	iret = 0
C
C*	Set up grid identifier.
C
	gtime  (1) = gdattm
	gtime  (2) = ' '
	levelg (2) = -1
C
C*	Define grid subset area.
C
	isx = iextnd (1) + 1
	isy = iextnd (2) + 1
	iex = kex - iextnd (3)
	iey = key - iextnd (4)
	igx = iex - isx + 1
	igy = iey - isy + 1
C
C*	Loop through all the parameters and levels.
C
	DO  ii = 1, LLGDHD
	    ighdr ( ii ) = 0
	END DO
C
	DO  igrid = 1, ngrid
C
C*	    Get the parameter name.
C
	    gparm = parm (igrid)
C
C*	    Define the level to be used.
C
	    levelg (1) = level (igrid)
C
C*	    Get the vertical coordinate.
C
	    jvcord = ivcord (igrid)
C
C*	    Move the data into a singly dimensioned array.
C
	    knt = 0
	    DO  iy = isy, iey
		DO  ix = isx, iex
		    knt = knt + 1
		    gwork (knt) = grid ( igrid, ix, iy )
		END DO
	    END DO
C
C*	    Write the grid to the grid file.
C
	    CALL DG_NWDT ( gwork, gtime, levelg, jvcord, gparm,
     +	                   ighdr, gpack, .true., iret )
	    IF  ( iret .ne. 0 )  THEN
		CALL ER_WMSG ( 'DG', iret, ' ', ier )
	    END IF
	END DO
C*
	RETURN
	END


C    %W% %G%
      subroutine ffread
C
C     THIS SUBROUTINE DECODES THE FF CARD AND CHECKS FOR ERRORS
C     IN THE PARAMETERS. IT IS CALLED BY INPUT1
C
C     Revs:
C     Aug/18/92 - DEM
C     Corrected misspelling of DTSJ in read statement

      include 'tspinc/params.inc'
      include 'tspinc/reread.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/blkcom1.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/param.inc'
      include 'tspinc/ffcard.inc'
      include 'tspinc/cntrl2.inc'
      include 'tspinc/vtchkc.inc'
      include 'tspinc/toler.inc'

C     declarations
      equivalence (sater, dtc), (isg2, istp)

      character dmpmlc*3

C     -  functions
      logical dbghere

C     -  local variables
      logical debug

C     -      begin     begin     begin     begin     begin     begin
      debug = dbghere('FFREAD  ')
C
C      READ PROGRAM PARAMETERS FROM FF CARD
C
      read (buffer, 10000) tsim, dt, endt, dtc, istp, toli, ilim,
     & delang, dcitol, dpmlt, dtsc, dtsj, frqbsf, lovtex, imblok,
     & mrelay, mfdep, lsolqt, limang, infbus, nodq, nogv, noex, nosc,
     & noload
10000 format (bz, 4x, f3.0, 1x, f3.1, 1x, f5.1, 1x, f3.1, 1x, i3, 1x,
     & f5.5, 1x, i3, 1x, f4.4, 1x, f2.0, 1x, f3.3, 3(1x, f2.0), 12(1x,
     & i1))

C     READ (BUFFER,1000)T,DT,ENDT,DTC,ISTP,TOLI,ILIM,DELANG,DCITOL
C     1 ,DPMLT,DTSC,DTSG,FRQBSE,LOVTEX,IMBLOK,MRELAY,MFDEP,LSOLQT
C     2  ,LIMANG,INFBUS, NODQ, NOGV, NOEX, NOSC, NOLOAD
C     1000 FORMAT(4X,F3.0,1X,F3.1,1X,F5.1,1X,F3.1,1X,I3,1X,F5.5,1X,I3,1X
C     1 ,F4.4,1X,F2.0,1X,F3.3,3(1X,F2.0),12(1X,I1))

C     -  Use FRQBSE from /SIMOPTS sectn if using new format
      if (ctlfmt .eq. 'OLD') frqbse = frqbsf
C
C      WRITE FF CARD IMAGE TO THE .SOL FILE
C
      irectp = 51
      idesc = 256 + 80
      irecln = 20
      if (debug) then
        call dbgeko('FFREAD  -  writing FF card to history file')
        call dbgwri('  IRECTP /record type/ = ', irectp)
        call dbgwri('  IDESC /rec descrip/  = ', idesc)
        call dbgwri('  IRECLN /rec length/  = ', irecln)
      endif
      call puthisrc(irectp, idesc, irecln, buffer)
C     WRITE (L8) 2,10,BUFFER
      if (frqbse .le. 0.0) frqbse = 60.
      if (dt .eq. 0.0) dt = 2.0
      if (dtc .le. 0.0) dtc = dt
      if (endt .le. 0.0) endt = 300.
      if (istp .le. 0) istp = 15
      write (outbuf, 10010) buffer
10010 format ('0', a)
      call prtout(1)
C
C     INITIALIZE LOW VOLTAGE SWITCH
C
      lovlt = 0
      if (ilim .eq. 0) ilim = 25
      if (toli .eq. 0.0) toli = .01
      if (delang .eq. 0.0) delang = 0.1
C
C        CONVERT DELANG TO RADIANS
C
      delang = delang*0.01745
      if (dcitol .eq. 0.0) dcitol = 8.0
      if (dmpmlt .eq. 0.0) then
        read (buffer, 10020) dmpmlc
10020   format (44x, a3)
        if (dmpmlc .eq. '   ') dmpmlt = 1.0
      endif
      if (dtsc .eq. 0.0) dtsc =  - 1.0
      if (dtsj .eq. 0.0) dtsj = 6.0
      mfdep = mfdep + 1
      if (mfdep .gt. 5) then
        iabort = 1
        write (errbuf(1), 10030) mfdep
        call prterr('E', 1)
10030   format ('0', 'FFREAD, ILLEGAL FREQ DEPENDENCE. MFDEP CODE ',
     &   'MUST BE LESS THAN 5.', i5)
      endif
      if (dt .lt. 0.0) then
        write (errbuf(1), 10040)
        call prterr('E', 1)
10040   format ('0', 'FFREAD, DELTA T IN COLUMNS 23-25 OF THE FF ',
     &   'CARD MUST BE GREATER THAN ZERO.')
        iabort = 1
      endif
      write (outbuf, 10050) ilim
      call prtout(1)
      write (outbuf, 10060) toli
      call prtout(1)
      write (outbuf, 10070) tsim
      call prtout(1)
      write (outbuf, 10080) dt
      call prtout(1)
      write (outbuf, 10090) endt
      call prtout(1)
      write (outbuf, 10100) delang
      call prtout(1)
      write (outbuf, 10110) dcitol
      call prtout(1)
      write (outbuf, 10120) dmpmlt
      call prtout(1)
      write (outbuf, 10130) dtc
      call prtout(1)
      write (outbuf, 10140) istp
      call prtout(1)
      write (outbuf, 10150) frqbse
      call prtout(1)
10050 format (1x, 'ILIM       =', i11)
10060 format (1x, 'TOLI       =', f11.7)
10070 format (1x, 'START TIME =', f11.2)
10080 format (1x, 'DELTA TIME =', f11.2)
10090 format (1x, 'END   TIME =', f11.2)
10100 format (1x, 'DELANG     =', f11.7)
10110 format (1x, 'DCITOL     =', f11.7)
10120 format (1x, 'DMPMLT     =', f11.7)
10130 format (1x, 'DTC        =', f11.7)
10140 format (1x, 'ISTP       =', i11)
10150 format (1x, 'BASE HZ    =', f11.2)
      return
      end