SUBROUTINE COOLRT
C     =================
C
C     Evaluation of cooling and heating rates for each ion
C
      INCLUDE 'IMPLIC.FOR'
      INCLUDE 'BASICS.FOR'
      INCLUDE 'ATOMIC.FOR'
      INCLUDE 'MODELQ.FOR'
      INCLUDE 'ODFPAR.FOR'
      INCLUDE 'ALIPAR.FOR'
      INCLUDE 'ARRAY1.FOR'
      INCLUDE 'ITERAT.FOR'
      parameter (pi4=4.*3.14159265d0)
      DIMENSION CLHT1(MDEPTH),CLHT2(MDEPTH),CLHT3(MDEPTH)
      DIMENSION CLRAT(MION,MDEPTH),HTRAT(MION,MDEPTH)
      COMMON/COOLCO/ABSOTI(MION,MDEPTH),EMISTI(MION,MDEPTH),
     *               ABSOC1(MDEPTH),EMISC1(MDEPTH)
C
      DO ID=1,ND
         DO ION=1,NION
            CLRAT(ION,ID)=0.
            HTRAT(ION,ID)=0.
         END DO
         CLHT1(ID)=0.
         CLHT2(ID)=0.
         CLHT3(ID)=0.
      END DO
C
      DO IJ=1,NFREQ
         IF(IJX(IJ).NE.-1) THEN
         CALL OPACFA(IJ)
         CALL RTEFR1(IJ)
         DO ID=1,ND
            DO ION=1,NION
               CLRAT(ION,ID)=CLRAT(ION,ID)+W(IJ)*EMISTI(ION,ID)
               HTRAT(ION,ID)=HTRAT(ION,ID)+
     &                       W(IJ)*ABSOTI(ION,ID)*RAD1(ID)
            END DO
            EM=EMIS1(ID)+SCAT1(ID)*RAD1(ID)
            CLHT2(ID)=CLHT2(ID)+W(IJ)*(EM-ABSO1(ID)*RAD1(ID))
            CLHT3(ID)=CLHT3(ID)+W(IJ)*EMIS1(ID)
         END DO
C
         if(ipopac.eq.1) then
            if(ij.le.nfreqc) then
               write(85,685) ij,freq(ij),(absoc1(id)/dens(id),id=1,nd)
            end if
         end if
         if(ipopac.eq.2) then
            if(ij.le.nfreqc) then
               write(87,686) ij,freq(ij)
               taud=abso1(1)*dedm1
               do id=1,nd
                  if(id.gt.1) taud=taud+deldmz(id-1)*
     *                        (absot(id-1)+absot(id))
               end do
            end if
         end if
  685 format(i5,1pe15.7/(1p8e10.3))
  686 format(i5,1pe15.7)
C
         END IF
      END DO
C
      if(icoolp.le.0) return
C
      DO ID=1,ND
         DO ION=1,NION
            CLHT1(ID)=CLHT1(ID)+CLRAT(ION,ID)-HTRAT(ION,ID)
         END DO
         WRITE(86,1060) ID,CLHT1(ID)*pi4,CLHT2(ID)*pi4,
     *                  CLHT3(ID)*pi4
 1060    FORMAT(I5,1P3E14.6)
      END DO
c
      if(icoolp.lt.2) return
c
      DO ID=1,ND
         WRITE(87,1071) id,
     *       ((CLRAT(ION,ID)-HTRAT(ION,ID))*pi4,ION=1,NION)
      END DO
c
      if(icoolp.lt.10) return
      WRITE(87,1070) ND,NION
      IOFE2=0
      DO ION=1,NION
         NN1=NFIRST(ION)
         IAT2=IATM(NN1)
         IF(NUMAT(IAT2).EQ.26 .and. IZ(ION).EQ.2) IOFE2=ION
      END DO
      REWIND 8
      READ(8,*) NDR
      READ(8,*) TTR,RSR
      DO ID=ND,1,-1
         READ(8,*) RSR
         WRITE(88,1071) RSR,CLRAT(IOFE2,ID)
      END DO
 1070 FORMAT(2I5)
 1071 FORMAT(i5/(1P6E13.5))     
      
      RETURN
      END