!! ALL MODULES

!! ACTION 21 (emission/absorption) subroutine

!! FACTOR OF 2 ERROR 6/16 partially corrected 9/17 integral photsums is now off by a factor of 1/2

#include "Definitions.INC"

module dipolemod
  implicit none
  DATATYPE, allocatable :: dipoleexpects(:,:,:)
end module dipolemod

module dipsubonemod
contains

subroutine dipolesub_one(wwin,bbin,in_abra,&    !! ok unused bbin
     in_aket,in_spfbra,in_spfket,diff_flag,dipole_expects,normsq)
  use r_parameters
  use spfsize_parameters
  use walkmod
  use fileptrmod
  use dotmod
  use biorthotypemod
  use biorthomod
  use arbitrarymultmod
  use orbgathersubmod
  use mpisubmod
  use utilmod
  implicit none
  type(biorthotype),target :: dipbiovar
  type(walktype),intent(in) :: wwin
  type(walktype),target,intent(in) :: bbin
  logical,intent(in) :: diff_flag   !! are in_spfbra, in_spfket different?
  DATATYPE, intent(in) :: in_spfbra(  spfsize, wwin%nspf ), &
       in_spfket(  spfsize, wwin%nspf ), &
       in_abra(numr,wwin%firstconfig:wwin%lastconfig),&
       in_aket(numr,wwin%firstconfig:wwin%lastconfig)
  DATATYPE,intent(out) :: dipole_expects(3),normsq
  DATATYPE,allocatable :: tempvector(:,:),tempspfs(:,:),abra(:,:),workspfs(:,:),&
       aket(:,:)
  DATATYPE :: nullcomplex(1),dipoles(3), dipolemat(wwin%nspf,wwin%nspf),csum
  DATAECS :: rvector(numr)
  integer :: i,lowspf,highspf,numspf
  DATATYPE,target :: smo(wwin%nspf,wwin%nspf)

  lowspf=1; highspf=wwin%nspf
  if (parorbsplit.eq.1) then
     call checkorbsetrange(wwin%nspf,i)
     if (i.ne.0) then
        OFLWR "error exit, can't do dipolesub parorbsplit.eq.1 with",wwin%nspf,"orbitals"; CFLST
     endif
     call getOrbSetRange(lowspf,highspf)
  endif
  numspf=highspf-lowspf+1

  allocate(tempvector(numr,wwin%firstconfig:wwin%lastconfig+1), tempspfs(spfsize,lowspf:highspf+1),&
       abra(numr,wwin%firstconfig:wwin%lastconfig+1),workspfs(spfsize,wwin%nspf),&
       aket(numr,wwin%firstconfig:wwin%lastconfig+1))

  tempvector=0; tempspfs=0; workspfs=0; abra=0; aket=0

  if (wwin%lastconfig.ge.wwin%firstconfig) then
     abra(:,wwin%firstconfig:wwin%lastconfig)=in_abra(:,:)
     aket(:,wwin%firstconfig:wwin%lastconfig)=in_aket(:,:)
  endif

#ifndef CNORMFLAG
  if (.not.diff_flag) then
     workspfs(:,:)=in_spfbra(:,:)
  else
#endif
  call bioset(dipbiovar,smo,numr,bbin)
  dipbiovar%hermonly=.true.
  call biortho(in_spfbra,in_spfket,workspfs,abra,dipbiovar)
  dipbiovar%hermonly=.false.
#ifndef CNORMFLAG
  endif
#endif

  normsq=dot(abra,aket,wwin%totadim)
  if (wwin%parconsplit.ne.0) then
     call mympireduceone(normsq)
  endif
!!$  OFLWR "Norm-squared for dipole: ",normsq

!! independent of R for now.  multiply by R for prolate  (R set to 1 for atom)
  call nucdipvalue(nullcomplex,dipoles)

  do i=1,numr
     tempvector(i,:)=aket(i,:)*bondpoints(i)
  enddo
  csum=0d0
  if (wwin%totadim.gt.0) then
     csum=hermdot(abra,tempvector,wwin%totadim)
  endif
  if (wwin%parconsplit.ne.0) then
     call mympireduceone(csum)
  endif
  dipoles(:)=dipoles(:)*csum

!! Z DIPOLE

  dipolemat(:,:)=0d0
  if (numspf.gt.0) then
     call mult_zdipole(numspf,in_spfket(:,lowspf:highspf),tempspfs(:,lowspf:highspf),1)
     call MYGEMM('C','N',wwin%nspf,numspf,spfsize,DATAONE, workspfs, spfsize, &
          tempspfs(:,lowspf:highspf), spfsize, DATAZERO, dipolemat(:,lowspf:highspf), wwin%nspf)
  endif
  if (parorbsplit.eq.1) then
     call mpiorbgather(dipolemat,wwin%nspf)
  endif
  if (parorbsplit.eq.3) then
     call mympireduce(dipolemat(:,:),wwin%nspf**2)
  endif

  rvector(:)=bondpoints(:)
  call arbitraryconfig_mult_singles(wwin,dipolemat,rvector,aket,tempvector,numr)
  dipole_expects(3)=0d0
  if (wwin%totadim.gt.0) then
     dipole_expects(3)=hermdot(abra,tempvector,wwin%totadim)
  endif
  if (wwin%parconsplit.ne.0) then
     call mympireduceone(dipole_expects(3))
  endif
  dipole_expects(3)=dipole_expects(3) + dipoles(3)

!! Y DIPOLE

  dipolemat(:,:)=0d0
  if (numspf.gt.0) then
     call mult_ydipole(numspf,in_spfket(:,lowspf:highspf),tempspfs(:,lowspf:highspf),1)

     call MYGEMM('C','N',wwin%nspf,numspf,spfsize,DATAONE, workspfs, spfsize, &
          tempspfs(:,lowspf:highspf), spfsize, DATAZERO, dipolemat(:,lowspf:highspf), wwin%nspf)
  endif
  if (parorbsplit.eq.1) then
     call mpiorbgather(dipolemat,wwin%nspf)
  endif
  if (parorbsplit.eq.3) then
     call mympireduce(dipolemat(:,:),wwin%nspf**2)
  endif

  rvector(:)=bondpoints(:)
  call arbitraryconfig_mult_singles(wwin,dipolemat,rvector,aket,tempvector,numr)
  dipole_expects(2)=0d0
  if (wwin%totadim.gt.0) then
     dipole_expects(2)=hermdot(abra,tempvector,wwin%totadim)
  endif
  if (wwin%parconsplit.ne.0) then
     call mympireduceone(dipole_expects(2))
  endif
  dipole_expects(2)=dipole_expects(2) + dipoles(2)

!! X DIPOLE

  dipolemat(:,:)=0d0
  if (numspf.gt.0) then
     call mult_xdipole(numspf,in_spfket(:,lowspf:highspf),tempspfs(:,lowspf:highspf),1)

     call MYGEMM('C','N',wwin%nspf,numspf,spfsize,DATAONE, workspfs, spfsize, &
          tempspfs(:,lowspf:highspf), spfsize, DATAZERO, dipolemat(:,lowspf:highspf), wwin%nspf)
  endif
  if (parorbsplit.eq.1) then
     call mpiorbgather(dipolemat,wwin%nspf)
  endif
  if (parorbsplit.eq.3) then
     call mympireduce(dipolemat(:,:),wwin%nspf**2)
  endif

  rvector(:)=bondpoints(:)
  call arbitraryconfig_mult_singles(wwin,dipolemat,rvector,aket,tempvector,numr)
  dipole_expects(1)=0d0
  if (wwin%totadim.gt.0) then
     dipole_expects(1)=hermdot(abra,tempvector,wwin%totadim)
  endif
  if (wwin%parconsplit.ne.0) then
     call mympireduceone(dipole_expects(1))
  endif
  dipole_expects(1)=dipole_expects(1) + dipoles(1)

  deallocate(tempvector,tempspfs,abra,aket,workspfs)

!!$#ifdef CNORMFLAG
!!$  dipole_expects(1)=dipole_expects(1)*abs(norm)/norm
!!$  dipole_expects(2)=dipole_expects(2)*abs(norm)/norm
!!$  dipole_expects(3)=dipole_expects(3)*abs(norm)/norm
!!$#endif

end subroutine dipolesub_one

end module dipsubonemod

module dipcallsubmod
contains

!! actually have numdata+1 data points in indipolearray

  subroutine dipolecall(numdata, indipolearrays, outenames, outtworknames, outangworknames, &
       outftnames, outoworknames, outophotonnames, sflag, referencepulses, npulses)
    use parameters
    use pulse_parameters
    use mpimod
    use pulsesubmod
    use utilmod
    implicit none
    integer,intent(in) :: numdata, sflag, referencepulses, npulses
    DATATYPE,intent(in) :: indipolearrays(0:autosize,3)
    character(len=SLN),intent(in) :: outenames(3), outtworknames(3), outangworknames(3), &
         outftnames(9), outoworknames(9), outophotonnames(9)
    complex*16,allocatable :: fftrans(:,:),eft(:,:),each_eft(:,:,:),dipolearrays(:,:),&
         dipole_diff(:,:)
!! real valued variables -- field (taken real always);
!!        integrals domega and circ polarization output left real valued
    real*8, allocatable :: &
         worksums(:,:,:), photsums(:,:,:), totworksums(:,:), totphotsums(:,:), &
         workpers(:,:,:), photpers(:,:,:), totworkpers(:,:), totphotpers(:,:), &
         sumrule(:,:), each_efield_ang(:,:,:), moment(:), dipole_ang(:,:), &
         angworksum0(:,:,:), totangworksum0(:,:),  efield(:,:), each_efield(:,:,:)
!! making integrals dt for work x y z complex valued for complex domcke wave mixing
    complex*16, allocatable :: worksum0(:,:,:), totworksum0(:,:)
    DATATYPE :: pots(3,npulses)
    real*8 :: estep, thistime, myenergy,xsecunits, windowfunct
    integer :: i,getlen,myiostat,ipulse,numft,ii
    character (len=7) :: number

#ifdef REALGO
    OFLWR "Cant use dipolesub for real valued code."; CFLST
#endif

    pots=0

    allocate(dipolearrays(0:numdata,3), efield(0:numdata,3), each_efield(0:numdata,3,npulses))
    dipolearrays=0; efield=0; each_efield=0

    if (sflag.ne.0) then
       thistime=numdata*par_timestep*autosteps
       write(number,'(I7)') 1000000+floor(thistime)
    endif

!! LENGTH GAUGE electric field vectdpot0

    do i=0,numdata
       if (referencepulses.eq.0) then
          do ipulse=1,npulses
             call vectdpot0(i*par_timestep*autosteps,0,pots(:,ipulse),-1,ipulse,ipulse)
          enddo
       else
          do ipulse=1,npulses
             call vectdpot0(i*par_timestep*autosteps,0,pots(:,ipulse),-1,ipulse+numpulses,ipulse+numpulses)
          enddo
       endif
       each_efield(i,:,:)=real(pots(:,:),8)  !! is real valued (imc = -1 above)
    enddo

    efield=0
    do ipulse=1,npulses
       efield(:,:)=efield(:,:)+each_efield(:,:,ipulse)
    enddo
    do i=0,numdata
       dipolearrays(i,:)=indipolearrays(i,:)-indipolearrays(0,:)
    enddo

    if (myrank.eq.1) then
       do ii=1,3
          open(171,file=outenames(ii),status="unknown",iostat=myiostat)
          call checkiostat(myiostat,"opening "//outenames(ii))
          write(171,*,iostat=myiostat) "#   ", numdata
          call checkiostat(myiostat,"writing "//outenames(ii))
          do i=0,numdata
             write(171,'(F18.12, T22, 400E20.8)',iostat=myiostat)  i*par_timestep*autosteps, &
                  dipolearrays(i,ii),efield(i,ii),each_efield(i,ii,:)
          enddo
          call checkiostat(myiostat,"writing "//outenames(ii))
          close(171)
       enddo
       if (sflag.ne.0) then
          do ii=1,3
             open(171,file=outenames(ii)(1:getlen(outenames(ii)))//number(2:7),status="unknown",iostat=myiostat)
             call checkiostat(myiostat,"opening "//outenames(ii)(1:getlen(outenames(ii)))//number(2:7))
             write(171,*,iostat=myiostat) "#   ", numdata
             call checkiostat(myiostat,"writing "//outenames(ii)(1:getlen(outenames(ii)))//number(2:7))
             do i=0,numdata
                write(171,'(F18.12, T22, 400E20.8)',iostat=myiostat)  i*par_timestep*autosteps, &
                     dipolearrays(i,ii),efield(i,ii),each_efield(i,ii,:)
             enddo
             call checkiostat(myiostat,"writing "//outenames(ii)(1:getlen(outenames(ii)))//number(2:7))
             close(171)
          enddo
       endif
    endif
    call mpibarrier()

!! work done by pulse integral dt

    allocate(dipole_diff(0:numdata,3), worksum0(0:numdata,3,npulses), totworksum0(0:numdata,3))
    dipole_diff=0d0;    worksum0=0;   totworksum0=0;

    do i=1,3
       call complexdiff(numdata+1,dipolearrays(:,i),dipole_diff(:,i),3)
    enddo
    dipole_diff(:,:)= dipole_diff(:,:) / par_timestep / autosteps

    do ipulse=1,npulses
       worksum0(0,:,ipulse) = (-1) * dipole_diff(0,:) * each_efield(0,:,ipulse) * par_timestep * autosteps
       do i=1,numdata
          worksum0(i,:,ipulse)=worksum0(i-1,:,ipulse) - dipole_diff(i,:) * each_efield(i,:,ipulse) * par_timestep * autosteps
       enddo
    enddo
    totworksum0(:,:)=0d0
    do ipulse=1,npulses
       totworksum0(:,:)=totworksum0(:,:)+worksum0(:,:,ipulse)
    enddo

    if (myrank.eq.1) then
       do ii=1,3
          open(171,file=outtworknames(ii),status="unknown",iostat=myiostat)
          call checkiostat(myiostat,"opening "//outtworknames(ii))
          do i=0,numdata
             write(171,'(A25,F10.5,400E20.8)') " EACH PULSE WORK T= ", i*par_timestep*autosteps,&
                  totworksum0(i,ii),worksum0(i,ii,:)
          enddo
          close(171)
       enddo

       if (sflag.ne.0) then
          do ii=1,3
             open(171,file=outtworknames(ii)(1:getlen(outtworknames(ii)))//number(2:7),status="unknown",iostat=myiostat)
             call checkiostat(myiostat,"opening "//outtworknames(ii)(1:getlen(outtworknames(ii)))//number(2:7))
             do i=0,numdata
                write(171,'(A25,F10.5,400E20.8)') " EACH PULSE WORK T= ", i*par_timestep*autosteps,&
                     totworksum0(i,ii),worksum0(i,ii,:)
             enddo
             close(171)
          enddo
       endif
    endif
    call mpibarrier()
    deallocate(worksum0,totworksum0)

    if (act21circ.ne.0) then
       allocate(angworksum0(0:numdata,3,npulses), totangworksum0(0:numdata,3), dipole_ang(0:numdata,3), &
            each_efield_ang(0:numdata,3,npulses), moment(0:numdata))
       angworksum0=0;  totangworksum0=0; dipole_ang=0;   each_efield_ang=0;    moment=0

!! not worrying about complex values

       dipole_ang(:,1) = real(dipolearrays(:,2) * dipole_diff(:,3) - dipolearrays(:,3) * dipole_diff(:,2),8)
       dipole_ang(:,2) = real(dipolearrays(:,3) * dipole_diff(:,1) - dipolearrays(:,1) * dipole_diff(:,3),8)
       dipole_ang(:,3) = real(dipolearrays(:,1) * dipole_diff(:,2) - dipolearrays(:,2) * dipole_diff(:,1),8)

       moment(:) = real(dipolearrays(:,1))**2 + real(dipolearrays(:,2))**2 + real(dipolearrays(:,3))**2

       do i=1,npulses
          each_efield_ang(:,1,i) = real(dipolearrays(:,2) * each_efield(:,3,i) - dipolearrays(:,3) * each_efield(:,2,i),8)
          each_efield_ang(:,2,i) = real(dipolearrays(:,3) * each_efield(:,1,i) - dipolearrays(:,1) * each_efield(:,3,i),8)
          each_efield_ang(:,3,i) = real(dipolearrays(:,1) * each_efield(:,2,i) - dipolearrays(:,2) * each_efield(:,1,i),8)
       enddo

       angworksum0=0
       do ipulse=1,npulses

!! real-valued variables all
          if (moment(0).ne.0) then
             angworksum0(0,:,ipulse) = (-1) * dipole_ang(0,:) * each_efield_ang(0,:,ipulse) / moment(0) * par_timestep * autosteps
          endif
          do i=1,numdata
             if (moment(i).ne.0) then
                angworksum0(i,:,ipulse) = angworksum0(i-1,:,ipulse) - dipole_ang(i,:) * each_efield_ang(i,:,ipulse) / moment(i) &
                     * par_timestep * autosteps
             else
                angworksum0(i,:,ipulse) = angworksum0(i-1,:,ipulse)
             endif
          enddo
       enddo
       totangworksum0(:,:)=0d0
       do ipulse=1,npulses
          totangworksum0(:,:)=totangworksum0(:,:)+angworksum0(:,:,ipulse)
       enddo

       if (myrank.eq.1) then
          do ii=1,3
             open(171,file=outangworknames(ii),status="unknown",iostat=myiostat)
             call checkiostat(myiostat,"opening "//outangworknames(ii))
             do i=0,numdata

!! not worrying about complex values

                write(171,'(A25,F10.5,400E20.8)') " EACH PULSE WORK T= ", i*par_timestep*autosteps,&
                     totangworksum0(i,ii),angworksum0(i,ii,:)

             enddo
             close(171)
          enddo

          if (sflag.ne.0) then
             do ii=1,3
                open(171,file=outangworknames(ii)(1:getlen(outangworknames(ii)))//number(2:7),status="unknown",iostat=myiostat)
                call checkiostat(myiostat,"opening "//outangworknames(ii)(1:getlen(outangworknames(ii)))//number(2:7))
                do i=0,numdata

!! not worrying about complex values

                   write(171,'(A25,F10.5,400E20.8)') " EACH PULSE WORK T= ", i*par_timestep*autosteps,&
                        totangworksum0(i,ii),angworksum0(i,ii,:)

                enddo
                close(171)
             enddo
          endif
       endif
       call mpibarrier()
       deallocate(angworksum0,totangworksum0,dipole_ang, each_efield_ang,moment)
    endif
    deallocate(dipole_diff)

    if (act21circ.ne.0) then
       numft=9
    else
       numft=3
    endif

    allocate(fftrans(0:numdata,numft), eft(0:numdata,numft), each_eft(0:numdata,numft,npulses))
    fftrans=0; eft=0; each_eft=0

    fftrans(:,1:3)=dipolearrays(:,:)
    eft(:,1:3)=efield(:,:)
    each_eft(:,1:3,:)=each_efield(:,:,:)

    deallocate(efield,each_efield,dipolearrays)

    do i=0,numdata
       fftrans(i,1:3) = fftrans(i,1:3) * windowfunct(i,numdata,21)  !! action 21
    enddo

    if (pulsewindowtoo.ne.0) then
       do i=0,numdata
          each_eft(i,1:3,:)=each_eft(i,1:3,:) * windowfunct(i,numdata,21)
          eft(i,1:3)=eft(i,1:3) * windowfunct(i,numdata,21)
       enddo
    endif

    do ii=1,3
       call zfftf_wrap_diff(numdata+1,fftrans(:,ii),ftdiff)
       call zfftf_wrap(numdata+1,eft(:,ii))
       do ipulse=1,npulses
          call zfftf_wrap(numdata+1,each_eft(:,ii,ipulse))
       enddo
    enddo

    fftrans(:,1:3)=fftrans(:,1:3)     * par_timestep * autosteps
    eft(:,1:3)=eft(:,1:3)             * par_timestep * autosteps
    each_eft(:,1:3,:)=each_eft(:,1:3,:) * par_timestep * autosteps

    if (act21circ.ne.0) then
!! XY, XZ, YX, YZ, ZX, ZY

       fftrans(:,4) = ( fftrans(:,1) + (0d0,1d0) * fftrans(:,2) )/sqrt(2d0)
       fftrans(:,5) = ( fftrans(:,1) + (0d0,1d0) * fftrans(:,3) )/sqrt(2d0)
       fftrans(:,6) = ( fftrans(:,2) + (0d0,1d0) * fftrans(:,1) )/sqrt(2d0)
       fftrans(:,7) = ( fftrans(:,2) + (0d0,1d0) * fftrans(:,3) )/sqrt(2d0)
       fftrans(:,8) = ( fftrans(:,3) + (0d0,1d0) * fftrans(:,1) )/sqrt(2d0)
       fftrans(:,9) = ( fftrans(:,3) + (0d0,1d0) * fftrans(:,2) )/sqrt(2d0)

       eft(:,4) = ( eft(:,1) + (0d0,1d0) * eft(:,2) )/sqrt(2d0)
       eft(:,5) = ( eft(:,1) + (0d0,1d0) * eft(:,3) )/sqrt(2d0)
       eft(:,6) = ( eft(:,2) + (0d0,1d0) * eft(:,1) )/sqrt(2d0)
       eft(:,7) = ( eft(:,2) + (0d0,1d0) * eft(:,3) )/sqrt(2d0)
       eft(:,8) = ( eft(:,3) + (0d0,1d0) * eft(:,1) )/sqrt(2d0)
       eft(:,9) = ( eft(:,3) + (0d0,1d0) * eft(:,2) )/sqrt(2d0)

       each_eft(:,4,:) = ( each_eft(:,1,:) + (0d0,1d0) * each_eft(:,2,:) )/sqrt(2d0)
       each_eft(:,5,:) = ( each_eft(:,1,:) + (0d0,1d0) * each_eft(:,3,:) )/sqrt(2d0)
       each_eft(:,6,:) = ( each_eft(:,2,:) + (0d0,1d0) * each_eft(:,1,:) )/sqrt(2d0)
       each_eft(:,7,:) = ( each_eft(:,2,:) + (0d0,1d0) * each_eft(:,3,:) )/sqrt(2d0)
       each_eft(:,8,:) = ( each_eft(:,3,:) + (0d0,1d0) * each_eft(:,1,:) )/sqrt(2d0)
       each_eft(:,9,:) = ( each_eft(:,3,:) + (0d0,1d0) * each_eft(:,2,:) )/sqrt(2d0)

    endif

    Estep=2*pi/par_timestep/autosteps/(numdata+1)

    allocate(&
         worksums(0:numdata,numft,npulses),photsums(0:numdata,numft,npulses),&
         totworksums(0:numdata,numft), totphotsums(0:numdata,numft), &
         workpers(0:numdata,numft,npulses),photpers(0:numdata,numft,npulses),&
         totworkpers(0:numdata,numft), totphotpers(0:numdata,numft), &
         sumrule(0:numdata,numft))
    worksums=0; photsums=0; totworksums=0; totphotsums=0;
    workpers=0; photpers=0; totworkpers=0; totphotpers=0;
    sumrule=0

    if (dipolesumstart.le.0d0) then
       do ipulse=1,npulses
          photpers(0,:,ipulse) = imag(fftrans(0,:)*conjg(each_eft(0,:,ipulse))) / PI !! NO 9/17 / 2   !! /2 6/16
          photsums(0,:,ipulse) = Estep * photpers(0,:,ipulse)
       enddo
    endif
    do i=1,numdata
       myenergy=i*Estep

!! sumrule sums to N for N electrons
       if (myenergy.ge.dipolesumstart.and.myenergy.le.dipolesumend.and.i.le.(numdata/2)) then
          sumrule(i,:)=sumrule(i-1,:) + Estep * imag(fftrans(i,:)*conjg(eft(i,:))) / abs(eft(i,:)**2) * myenergy * 2 / PI
          do ipulse=1,npulses
             photpers(i,:,ipulse) = imag(fftrans(i,:)*conjg(each_eft(i,:,ipulse))) / PI  !! NO 9/17  / 2  !! /2 6/16
             workpers(i,:,ipulse) = imag(fftrans(i,:)*conjg(each_eft(i,:,ipulse))) / PI * myenergy
             photsums(i,:,ipulse) = photsums(i-1,:,ipulse) + Estep * photpers(i,:,ipulse)
             worksums(i,:,ipulse) = worksums(i-1,:,ipulse) + Estep * workpers(i,:,ipulse)
          enddo
       else
          sumrule(i,:)=sumrule(i-1,:)
          photsums(i,:,:)  =  photsums(i-1,:,:)
          worksums(i,:,:)=worksums(i-1,:,:)
       endif
    enddo
    totphotsums=0
    totworksums=0
    totphotpers=0
    totworkpers=0
    do ipulse=1,npulses
       totphotsums(:,:)=totphotsums(:,:)+photsums(:,:,ipulse)
       totworksums(:,:)=totworksums(:,:)+worksums(:,:,ipulse)
       totphotpers(:,:)=totphotpers(:,:)+photpers(:,:,ipulse)
       totworkpers(:,:)=totworkpers(:,:)+workpers(:,:,ipulse)
    enddo

    if (myrank.eq.1) then
       do ii=1,numft
          open(171,file=outftnames(ii),status="unknown",iostat=myiostat)
          call checkiostat(myiostat,"opening "//outftnames(ii))
          write(171,'(A120)',iostat=myiostat) &
               "## Photon energy (column 1); D(omega) (2,3); E(omega) (4,5); response (6,7); cross sect (9); integrated (10)"
          call checkiostat(myiostat,"writing "//outftnames(ii))
          write(171,'(A120)') "## UNITLESS RESPONSE FUNCTION FOR ABSORPTION/EMISSION 2 omega im(D(omega)E(omega)^*) IN COLUMN 7"
          write(171,'(A120)') "## QUANTUM MECHANICAL PHOTOABSORPTION/EMISSION CROSS SECTION IN MEGABARNS (no factor of 1/3) IN COLUMN NINE"
          write(171,'(A120)') "## INTEGRATED DIFFERENTIAL OSCILLATOR STRENGTH (FOR SUM RULE) IN COLUMN 10"
          write(171,*)

          do i=0,numdata
             myenergy=i*Estep

!! LENGTH GAUGE (electric field) WAS FT'ed , OK with usual formula multiply by wfi
!! UNITLESS RESPONSE FUNCTION FOR ABSORPTION/EMISSION 2 omega im(D(omega)E(omega)^*) IN COLUMN 7
!! QUANTUM MECHANICAL PHOTOABSORPTION/EMISSION CROSS SECTION IN MEGABARNS (no factor of 1/3) IN COLUMN NINE
!! INTEGRATED DIFFERENTIAL OSCILLATOR STRENGTH (FOR SUM RULE) IN COLUMN 10

             xsecunits = 5.291772108d0**2 * 4d0 * PI / 1.37036d2 * myenergy

!! NOW FACTOR (2 omega) IN COLUMNS 6,7   v1.16 12-2015

             write(171,'(F18.12, T22, 400E20.8)',iostat=myiostat)  myenergy, &
                  fftrans(i,ii), eft(i,ii), fftrans(i,ii)*conjg(eft(i,ii)) * 2 * myenergy, &
                  fftrans(i,ii)*conjg(eft(i,ii)) / abs(eft(i,ii)**2) * xsecunits, sumrule(i,ii)
          enddo
          call checkiostat(myiostat,"writing "//outftnames(ii))
          close(171)

!!  NUMBER OF PHOTONS ABSORBED AND AND WORK DONE BY EACH PULSE
!!  worksum0 the time integral converges right after pulse is finished... others take longer

          open(171,file=outoworknames(ii),status="unknown",iostat=myiostat)
          call checkiostat(myiostat,"opening "//outoworknames(ii))
          do i=0,numdata
             myenergy=i*Estep
             if (myenergy.ge.dipolesumstart.and.myenergy.le.dipolesumend) then
                write(171,'(A25,F10.5,400E20.8)') " WORK EACH PULSE E= ", myenergy, &
                     totworksums(i,ii), totworkpers(i,ii), worksums(i,ii,:), workpers(i,ii,:)
             endif
          enddo
          close(171)

          open(171,file=outophotonnames(ii),status="unknown",iostat=myiostat)
          call checkiostat(myiostat,"opening "//outophotonnames(ii))
          do i=0,numdata
             myenergy=i*Estep
             if (myenergy.ge.dipolesumstart.and.myenergy.le.dipolesumend) then
                write(171,'(A25,F10.5,400E20.8)') "PHOTONS EACH PULSE E= ", myenergy, &
                     totphotsums(i,ii), totphotpers(i,ii), photsums(i,ii,:), photpers(i,ii,:)
             endif
          enddo
          close(171)

          if (sflag.ne.0) then

             open(171,file=outoworknames(ii)(1:getlen(outoworknames(ii)))//number(2:7),status="unknown",iostat=myiostat)
             call checkiostat(myiostat,"opening "//outoworknames(ii)(1:getlen(outoworknames(ii)))//number(2:7))
             do i=0,numdata
                myenergy=i*Estep
                if (myenergy.ge.dipolesumstart.and.myenergy.le.dipolesumend) then
                   write(171,'(A25,F10.5,400E20.8)') " WORK EACH PULSE E= ", myenergy, &
                        totworksums(i,ii), totworkpers(i,ii), worksums(i,ii,:), workpers(i,ii,:)
                endif
             enddo
             close(171)

             open(171,file=outophotonnames(ii)(1:getlen(outophotonnames(ii)))//number(2:7),status="unknown",iostat=myiostat)
             call checkiostat(myiostat,"opening "//outophotonnames(ii)(1:getlen(outophotonnames(ii)))//number(2:7))
             do i=0,numdata
                myenergy=i*Estep
                if (myenergy.ge.dipolesumstart.and.myenergy.le.dipolesumend) then
                   write(171,'(A25,F10.5,400E20.8)') "PHOTONS EACH PULSE E= ", myenergy, &
                        totphotsums(i,ii), totphotpers(i,ii), photsums(i,ii,:), photpers(i,ii,:)
                endif
             enddo
             close(171)

             open(171,file=outftnames(ii)(1:getlen(outftnames(ii)))//number(2:7),status="unknown",iostat=myiostat)
             call checkiostat(myiostat,"opening "//outftnames(ii)(1:getlen(outftnames(ii)))//number(2:7))
             write(171,'(A120)',iostat=myiostat) &
                  "## Photon energy (column 1); D(omega) (2,3); E(omega) (4,5); response (6,7); cross sect (9); integrated (10)"
             call checkiostat(myiostat,"writing "//outftnames(ii)(1:getlen(outftnames(ii)))//number(2:7))
             write(171,'(A120)') "## UNITLESS RESPONSE FUNCTION FOR ABSORPTION/EMISSION 2 omega im(D(omega)E(omega)^*) IN COLUMN 7"
             write(171,'(A120)') "## QUANTUM MECHANICAL PHOTOABSORPTION/EMISSION CROSS SECTION IN MEGABARNS (no factor of 1/3) IN COLUMN NINE"
             write(171,'(A120)') "## INTEGRATED DIFFERENTIAL OSCILLATOR STRENGTH (FOR SUM RULE) IN COLUMN 10"
             write(171,*)

             do i=0,numdata
                myenergy=i*Estep

                xsecunits = 5.291772108d0**2 * 4d0 * PI / 1.37036d2 * myenergy

!! NOW FACTOR (2 omega) IN COLUMNS 6,7   v1.16 12-2015

                write(171,'(F18.12, T22, 400E20.8)',iostat=myiostat)  myenergy, &
                     fftrans(i,ii), eft(i,ii), fftrans(i,ii)*conjg(eft(i,ii)) * 2 * myenergy, &
                     fftrans(i,ii)*conjg(eft(i,ii)) / abs(eft(i,ii)**2) * xsecunits, sumrule(i,ii)
             enddo
             call checkiostat(myiostat,"writing "//outftnames(ii)(1:getlen(outftnames(ii)))//number(2:7))
             close(171)
          endif
       enddo    !! do ii=1,numft
    endif  !! myrank
    call mpibarrier()

    deallocate(fftrans,eft,each_eft)
    deallocate(worksums,photsums,totworksums,totphotsums,  workpers,photpers,totworkpers,totphotpers,&
         sumrule)

  end subroutine dipolecall

   subroutine dipolesub0(in_spfbra,in_spfket,in_abra,in_aket,diff_flag,normsq)
     use dipolemod
     use dipsubonemod
     use parameters
     use configmod
     use mpisubmod
     use pulse_parameters !! reference_pulses
     implicit none
     logical,intent(in) :: diff_flag  !! are bra & ket different?
     DATATYPE,intent(in) :: in_spfbra(totspfdim), in_abra(tot_adim,mcscfnum), &
          in_spfket(totspfdim), in_aket(tot_adim,mcscfnum)
     DATATYPE :: myexpects(3), mcexpects(3,mcscfnum), &
          axx(mcscfnum),ayy(mcscfnum),azz(mcscfnum),sxx(mcscfnum),syy(mcscfnum),&
          szz(mcscfnum),drivingoverlap(mcscfnum)
     DATATYPE,intent(out) :: normsq(mcscfnum)
     character(len=SLN) :: dipfiles(3), tworkfiles(3), angworkfiles(3), ftfiles(9), &
          oworkfiles(9), ophotonfiles(9)
     integer :: imc,sflag
     integer, save :: lastouttime=0, calledflag=0
     real*8 :: thistime

     myexpects=0;mcexpects=0;axx=0;ayy=0;azz=0;sxx=0;syy=0;szz=0;normsq=0;drivingoverlap=0

     do imc=1,mcscfnum
        call dipolesub_one(www,bioww,in_abra(:,imc),in_aket(:,imc),in_spfbra(:),in_spfket(:),&
             diff_flag,mcexpects(:,imc),normsq(imc))
     enddo

     if (drivingflag.ne.0) then
#ifdef CNORMFLAG
        OFLWR "Error, driving with dipole not supported c-norm"; CFLST
#endif
        call dipolesub_driving(axx,ayy,azz,sxx,syy,szz,mcscfnum)
        mcexpects(1,:)=mcexpects(1,:)+axx(:)+CONJUGATE(axx(:))+sxx*drivingproportion**2
        mcexpects(2,:)=mcexpects(2,:)+ayy(:)+CONJUGATE(ayy(:))+syy*drivingproportion**2
        mcexpects(3,:)=mcexpects(3,:)+azz(:)+CONJUGATE(azz(:))+szz*drivingproportion**2

!! for time slot zero
        call getdrivingoverlap(drivingoverlap,mcscfnum)
        normsq(:)=normsq(:)+drivingproportion**2 + drivingoverlap(:) + CONJUGATE(drivingoverlap(:))
     endif

     dipoleexpects(calledflag,:,1)=0d0

     do imc=1,mcscfnum
        dipoleexpects(calledflag,:,1) = dipoleexpects(calledflag,:,1) + mcexpects(:,imc) / mcscfnum
     enddo

     if (mod(calledflag,dipmodtime).eq.0.and.calledflag.gt.0) then

        OFLWR "Go emission/absorption action 21... "; CFL

        thistime=calledflag*par_timestep*autosteps
        sflag=0
        if (floor(thistime/diptime).gt.lastouttime) then
           lastouttime=floor(thistime/diptime)
           sflag=1
        endif

!!$  subroutine dipolecall(numdata, indipolearrays, outenames, outtworknames, outangworknames, &
!!$       outftnames, outoworknames, outophotonnames, sflag)

        dipfiles(:) = (/ xdipfile, ydipfile, zdipfile /)
        tworkfiles(:) = (/ xtworkfile, ytworkfile, ztworkfile /)
        angworkfiles(:) = (/ yztworkfile, zxtworkfile, xytworkfile /)
        ftfiles(:) = (/ xdftfile, ydftfile, zdftfile, &
             xydftfile, xzdftfile, yxdftfile, yzdftfile, zxdftfile, zydftfile /)
        oworkfiles(:) = (/ xoworkfile, yoworkfile, zoworkfile, &
             xyoworkfile, xzoworkfile, yxoworkfile, yzoworkfile, zxoworkfile, zyoworkfile /)
        ophotonfiles(:) = (/ xophotonfile, yophotonfile, zophotonfile, &
             xyophotonfile, xzophotonfile, yxophotonfile, yzophotonfile, zxophotonfile, zyophotonfile /)

        if (reference_pulses.eq.0) then
           call dipolecall(calledflag, dipoleexpects(:,:,1), &
                dipfiles, tworkfiles, angworkfiles, ftfiles, oworkfiles, ophotonfiles, sflag, 0, numpulses)
        else
           call dipolecall(calledflag, dipoleexpects(:,:,1), &
                dipfiles, tworkfiles, angworkfiles, ftfiles, oworkfiles, ophotonfiles, sflag, 1, reference_pulses)
        endif

        OFLWR "     ..done emission/absorption"; CFL

     endif       !! calledflag (dipmodtime)

     calledflag=calledflag+1

   end subroutine dipolesub0

end module dipcallsubmod

module dipsubmod
contains

subroutine dipolesub_initial()
  use dipolemod
  use parameters
  implicit none

  allocate(dipoleexpects(0:autosize,3,1))   !! x,y,z

end subroutine

subroutine dipolesub_final()
  use dipolemod
  implicit none
  deallocate( dipoleexpects )

end subroutine dipolesub_final

subroutine dipolesub()   !! action 21
  use parameters
  use dipcallsubmod
  use xxxmod
  implicit none
  integer,save :: xcalledflag=0
  DATATYPE :: normsq(mcscfnum)

  normsq=0
  if (mod(xcalledflag,autosteps).eq.0) then
     call dipolesub0(yyy%cmfspfs(:,0),yyy%cmfspfs(:,0),yyy%cmfavec(:,:,0),yyy%cmfavec(:,:,0),.false.,normsq)
  endif
  xcalledflag=xcalledflag+1

end subroutine dipolesub

subroutine redo_dipolesub(alg,diff_flag)  !! action 29
  use parameters
  use dipcallsubmod
  use configmod
  use xxxmod
  use mpisubmod
  use mpimod
  implicit none
  integer, intent(in) :: alg
  logical,intent(in) :: diff_flag   !! read two different files using fluxmofile2 etc.?
  integer :: k,nt,i,molength,alength,  BatchSize,NBat,ketbat,ketreadsize, &
       kettime,imc, ispf, myiostat
  real*8 :: MemTot,MemVal, dt, MemNum
  DATATYPE :: nullvector(numr), normsq(mcscfnum)
  DATATYPE, allocatable :: ketmo(:,:,:),ketavec(:,:,:,:),&
       read_ketmo(:,:),read_ketavec(:,:,:,:),bramo(:,:,:),braavec(:,:,:,:),&
       read_bramo(:,:),read_braavec(:,:,:,:)

  nullvector=0; normsq=0

  dt=real(FluxInterval*FluxSkipMult,8)*par_timestep;
  nt=floor(real(numpropsteps,8)/fluxinterval/fluxskipmult)

  if (abs(dt - par_timestep*autosteps)/dt .gt. 1d-3) then
     OFLWR "error, need fluxskipmult*fluxinterval*par_timestep.eq.autotimestep for action 29"
     WRFL "   fluxskipmult, fluxinterval, par_timestep, autosteps, autotimestep "
     WRFL fluxskipmult, fluxinterval, par_timestep, autosteps, autotimestep; CFLST
  endif

  call mpibarrier()
  OFLWR "Go recompute dipolemoment"; CFL

!! determine if we should do batching or not
!! 250,000 words/MB, real*8 2words/#, complex*16 4words/#

#ifdef REALGO
  MemVal = 1.25d5
#else
  MemVal = 6.25d4
#endif

!! memory based on rank 1 which right now stores the entire orbital vector, which is wasteful.
!! Unsatisfactory: need better MPI I/O.

  MemNum=0d0

!!$    if (parorbsplit.eq.3) then
!!$       MemNum = MemNum + spfsize*nspf*nprocs
!!$    else

  MemNum = MemNum + spfsize*nspf

!!$    endif

  if (par_consplit.ne.0) then
     MemNum = MemNum + www%numconfig*numr*mcscfnum
  else
     MemNum = MemNum + www%maxconfigsperproc*numr*mcscfnum
  endif

  call openfile()
  write(mpifileptr,'(A30,F9.3,A3)') " Guess at necessary memory is ",&
       (nt+1)*MemNum/MemVal," MB"
  if(alg.eq.0) then
     write(mpifileptr,*) "   ...will be computed with all of psi in core"
     BatchSize=nt+1
  else
     MemTot=real(alg,8)
     write(mpifileptr,*) "    ... computed with all psi being read in batches"
     write(mpifileptr,'(A33,F9.3,A3)') "        Desired amount of memory ",MemTot," MB"
     BatchSize=floor(MemTot * MemVal / MemNum)
     if(BatchSize.lt.1) then
        write(mpifileptr,*) "Tiny amount of memory or huge wavefunction, Batchsize is 1"
        BatchSize=1
     else if(BatchSize.ge.nt+1) then
        write(mpifileptr,*) "Good, there is enough memory for only one batch."
        BatchSize=nt+1
     else
        write(mpifileptr,*) "Batchsize is ",BatchSize,"/",(nt+1)
     endif
  endif
  call closefile()

  call mpibarrier()
  OFLWR "Allocating psi arrays for recomputing dipolemoment"; CFL

  allocate(ketmo(spfsize,nspf,BatchSize), &
       ketavec(numr,www%firstconfig:www%lastconfig,mcscfnum,BatchSize))
  ketmo=0
  if (www%lastconfig.ge.www%firstconfig) then
     ketavec=0
  endif
  if (myrank.eq.1) then
     if (parorbsplit.eq.3) then
        allocate(read_ketmo(spfsize*nprocs,nspf))
     else
        allocate(read_ketmo(spfsize,nspf))
     endif
  else
     allocate(read_ketmo(1,nspf))
  endif
  read_ketmo=0

  if (myrank.eq.1) then
     allocate(read_ketavec(numr,www%numconfig,mcscfnum,BatchSize))
  else
     allocate(read_ketavec(1,1,mcscfnum,BatchSize))
  endif
  read_ketavec=0

  if (.not.diff_flag) then  !! avoid warn ubound
     allocate(bramo(1,1,1),  braavec(1,1,1,1), read_bramo(1,1), read_braavec(1,1,1,1))
     bramo=0; braavec=0; read_bramo=0; read_braavec=0
  else

     allocate(bramo(spfsize,nspf,BatchSize), &
          braavec(numr,www%firstconfig:www%lastconfig,mcscfnum,BatchSize))
     bramo=0
     if (www%lastconfig.ge.www%firstconfig) then
        braavec=0
     endif
     if (myrank.eq.1) then
        if (parorbsplit.eq.3) then
           allocate(read_bramo(spfsize*nprocs,nspf))
        else
           allocate(read_bramo(spfsize,nspf))
        endif
     else
        allocate(read_bramo(1,nspf))
     endif
     read_bramo=0

     if (myrank.eq.1) then
        allocate(read_braavec(numr,www%numconfig,mcscfnum,BatchSize))
     else
        allocate(read_braavec(1,1,mcscfnum,BatchSize))
     endif
     read_braavec=0

  endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  NBat=ceiling(real(nt+1)/real(BatchSize))
  ketreadsize=0

  if (myrank.eq.1) then
     inquire (iolength=molength) read_ketmo(:,:)
     inquire (iolength=alength) read_ketavec(:,:,:,1)
  endif
  call mympiibcastone(molength,1); call mympiibcastone(alength,1)

  call openfile()
  write(mpifileptr,*) "MO record length is ",molength
  write(mpifileptr,*) "AVEC record length is ",alength
  call closefile()

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!! begin the ket batch read loop
  do ketbat=1,NBat

     OFLWR "Reading batch ", ketbat, " of ", NBat; CFL
     ketreadsize=min(BatchSize,nt+1-(ketbat-1)*BatchSize)

!! KET ORBITALS
     if(myrank.eq.1) then
        open(1001,file=fluxmofile,status="old",form="unformatted",&
             access="direct",recl=molength,iostat=myiostat)
        call checkiostat(myiostat,"opening "//fluxmofile)
     endif
     do i=1,ketreadsize
        if(myrank.eq.1) then
           k=FluxSkipMult*((ketbat-1)*BatchSize+i-1)+1
           read(1001,rec=k,iostat=myiostat) read_ketmo(:,:)
           call checkiostat(myiostat,"reading "//fluxmofile)
        endif
        if (parorbsplit.ne.3) then
           if (myrank.eq.1) then
              ketmo(:,:,i)=read_ketmo(:,:)
           endif
           call mympibcast(ketmo(:,:,i),1,totspfdim)
        else
           do ispf=1,nspf
              call splitscatterv(read_ketmo(:,ispf),ketmo(:,ispf,i))
           enddo
        endif
     enddo       !! do i=1,ketreadsize
     if (myrank.eq.1) then
        close(1001)
     endif
!! KET A-VECTOR
     if(myrank.eq.1) then
        open(1002,file=fluxafile,status="old",form="unformatted",&
             access="direct",recl=alength,iostat=myiostat)
        call checkiostat(myiostat,"opening "//fluxafile)
        do i=1,ketreadsize
           k=FluxSkipMult*((ketbat-1)*BatchSize+i-1)+1
           read(1002,rec=k,iostat=myiostat) read_ketavec(:,:,:,i)
        enddo
        call checkiostat(myiostat,"reading "//fluxafile)
        close(1002)
     endif
     if (par_consplit.eq.0) then
        if (myrank.eq.1) then
           ketavec(:,:,:,1:ketreadsize)=read_ketavec(:,:,:,1:ketreadsize)
        endif
        call mympibcast(ketavec(:,:,:,1:ketreadsize),1,numr*www%numconfig*mcscfnum*ketreadsize)
     else
        do i=1,ketreadsize
           do imc=1,mcscfnum
              if (tot_adim.gt.0) then
                 call myscatterv(read_ketavec(:,:,imc,i),&
                      ketavec(:,:,imc,i),configs_perproc(:)*numr)
              else
                 call myscatterv(read_ketavec(:,:,imc,i),&
                      nullvector(:),configs_perproc(:)*numr)
              endif
           enddo
        enddo
     endif

     if (diff_flag) then

!! BRA ORBITALS
        if(myrank.eq.1) then
           open(2001,file=fluxmofile2,status="old",form="unformatted",&
                access="direct",recl=molength,iostat=myiostat)
           call checkiostat(myiostat,"opening "//fluxmofile2)
        endif
        do i=1,ketreadsize
           if(myrank.eq.1) then
              k=FluxSkipMult*((ketbat-1)*BatchSize+i-1)+1
              read(2001,rec=k,iostat=myiostat) read_bramo(:,:)
              call checkiostat(myiostat,"reading "//fluxmofile)
           endif
           if (parorbsplit.ne.3) then
              if (myrank.eq.1) then
                 bramo(:,:,i)=read_bramo(:,:)
              endif
              call mympibcast(bramo(:,:,i),1,totspfdim)
           else
              do ispf=1,nspf
                 call splitscatterv(read_bramo(:,ispf),bramo(:,ispf,i))
              enddo
           endif
        enddo       !! do i=1,ketreadsize
        if (myrank.eq.1) then
           close(2001)
        endif
!! BRA A-VECTOR
        if(myrank.eq.1) then
           open(2002,file=fluxafile2,status="old",form="unformatted",&
                access="direct",recl=alength,iostat=myiostat)
           call checkiostat(myiostat,"opening "//fluxafile2)
           do i=1,ketreadsize
              k=FluxSkipMult*((ketbat-1)*BatchSize+i-1)+1
              read(2002,rec=k,iostat=myiostat) read_braavec(:,:,:,i)
           enddo
           call checkiostat(myiostat,"reading "//fluxafile2)
           close(2002)
        endif
        if (par_consplit.eq.0) then
           if (myrank.eq.1) then
              braavec(:,:,:,1:ketreadsize)=read_braavec(:,:,:,1:ketreadsize)
           endif
           call mympibcast(braavec(:,:,:,1:ketreadsize),1,numr*www%numconfig*mcscfnum*ketreadsize)
        else
           do i=1,ketreadsize
              do imc=1,mcscfnum
                 if (tot_adim.gt.0) then
                    call myscatterv(read_braavec(:,:,imc,i),&
                         braavec(:,:,imc,i),configs_perproc(:)*numr)
                 else
                    call myscatterv(read_braavec(:,:,imc,i),&
                         nullvector(:),configs_perproc(:)*numr)
                 endif
              enddo
           enddo
        endif

     endif  ! diff_flag

!! loop over all time for the ket of the dipole integral
     do kettime=1,ketreadsize
        if (diff_flag) then
           call dipolesub0(bramo(:,:,kettime),ketmo(:,:,kettime),&
                braavec(:,:,:,kettime),ketavec(:,:,:,kettime),.true.,normsq(:))
        else
           call dipolesub0(ketmo(:,:,kettime),ketmo(:,:,kettime),&
                ketavec(:,:,:,kettime),ketavec(:,:,:,kettime),.false.,normsq(:))
        endif
     enddo

     OFLWR "Dipole norm-squared: ", normsq(:)

  enddo  !! ketbat

  deallocate(ketmo, ketavec, read_ketmo, read_ketavec)
  deallocate(bramo, braavec, read_bramo, read_braavec)

  OFLWR "Done recomputing dipole, stopping"; CFLST

end subroutine redo_dipolesub

end module dipsubmod


* Not really used by normal3d, but needed in order to link with qinp
      MODULE LISTS
        INTEGER, ALLOCATABLE, DIMENSION(:,:)   :: KOUNT, MOUNT
        INTEGER, ALLOCATABLE, DIMENSION(:,:)   :: TTRANS
        INTEGER ISTRANS
      END MODULE LISTS

      PROGRAM NORMAL3D
*
*     Version 3.0 (14 Dec 2010)
*
* EAM Jan 1996	- Initial release as part of version 2.2
* EAM Aug 1996	- Add -expand option to deal with file indirection
* EAM Feb 1997	- Handle additional MATERIAL records
*		  -stereo flag to generate left.r3d and right.r3d
* EAM Apr 1997	- now handles labels and glowlights
* EAM May 1997	- (well, now it does) V2.3c
* EAM Jul 1997	- quadric surfaces, ISOLATION
* EAM Oct 1997	- fix bug that prevented handling CYLFLAT objects
* EAM Nov 1997	- handle VERTEXRGB records, allow # as comment
* EAM Jul 1998	- remove Q format from LABEL input; wrong, but fewer complaints
* EAM Oct 1998	- check environmental variable R3D_LIB for input file indirection
* EAM Feb 1999	- FRONTCLIP, BACKCLIP
* EAM Jul 1999	- preliminary work towards a post-hoc rotation option
* EAM Jan 2000	- V2.5b general release
* EAM Feb 2000	- compatible with new object type VERTRANSP
* EAM Sep 2000	- V2.5e uncompress files ending in .Z or .gz
* EAM Feb 2001	- BOUNDING_PLANEs
* EAM Feb 2002	- [-stereo [TMPNAM]] [-angle AA]
*		  stereo defaults to shear (as before); force EYEPOS = 0
*		  but specifying -angle AA switches to +/- AA separation instead
*		  You can't win:  shear breaks bounding planes, AA breaks Z-clip
* EAM Dec 2010	- Dynamic array allocation to match that in render
*
*	This program is part of the Raster3D package.
*	It is simply a stripped down version of the input section of render.
*	It reads in a render input file, applies the transformation matrix in
*	the header, and writes out a modified render input file describing the
*	same image using a unitary transformation matrix and normalized object
*	coordinates. All header records are basically passed through without
*	interpretation except for the transformation matrix (which changes to the
*	identity matrix) and the format lines (which are set to *).
*
*     Input (line by line except where noted):
*
*     - TITLE    anything you like
*     - NTX,NTY  tiles in each direction
*     - NPX,NPY  pixels per tile to compute in each direction
*     - SCHEME   pixel averaging scheme (0, 1, 2, 3 or 4)
*       - 0 no anti-aliasing, maintain alpha channel
*       - 1 no anti-aliasing, no alpha channel
*       - 2 means 2x2 computing pixels for 1 output pixel
*       - 3 means 3x3 computing pixels for 2x2 output pixels
*       - 4 like 3, but NTX..NPY specify final rather than initial raster
*     - BKGND    background colour (r,g,b in range 0 to 1)
*     - SHADOW   "shadow mode?" (T or F)
*     - IPHONG   Phong power (e.g., 20)
*     - STRAIT   straight-on (2ndary) light component (e.g., 0.1)
*     - AMBIEN   ambient light component (e.g., 0.05)
*     - SPECLR   specular reflection component (e.g., 0.30)
*     - EYEPOS   eye position (e.g., 4)
*       - relative to 1=narrow dimension of screen
*       - used for perspective (0.0 = no perspective)
*       - don't put it in the transformation matrix yourself
*     - SOURCE   main light source position (x,y,z components)
*       - vector length ignored, point source is at infinity
*     - TMAT     global transformation on input objects
*       - postfix 4x4 matrix on 4 lines, as you would write it
*       - upper left 3x3 must be pure rotation
*       - lower left 1x3 is translation
*       - lower right 1x1 is global scaling (reduction)
*       - upper right 3x1 causes extra perspective (should be 0)
*       - applies to homogeneous co-ordinates (x,y,z,1)
*       - radii are only scaled down by global scaling TMAT(4,4)
*     - INMODE   object input mode (1, 2, or 3)
*       - mode 1:  all objects are triangles
*       - mode 2:  all objects are spheres
*       - mode 3:  each object will be preceded by type
*     - INFMT or INFMTS   object input format(s), 1 per line
*       - one format for modes 1 and 2, or three for mode 3
*       - each is fortran format in parentheses, or single *
*       - for 3 formats, the order of formats and details is:
*         - triangle:  x1,y1,z1,x2,y2,z2,x3,y3,z3,r,g,b
*         - sphere:    x,y,z,radius,r,g,b
*         - trcone:    x1,y1,z1,rad1,x2,y2,z2,rad2,r,g,b
*	  - cylinder:  as truncated cone, but 2nd radius ignored
*     - objects
*       - modes 1,2:  each object starts on a new line
*         - read according to the single format given
*       - mode 3:  each object is preceded by a line giving type
*         - type 1:  triangle
*         - type 2:  sphere
*         - type 3:  cylinder with rounded ends
*         - type 4:  trcone made of spheres (not implemented)
*         - type 5:  cylinder with flat ends
*         - type 6:  plane (=triangle with infinite extent)
*         - type 7:  normal vectors for previous triangle
*         - type 8:  material definition which applies to subsequent objects
*         - type 9:  end previous material
*	  - type 10: font specifier, we need to note coordinate convention
*	  - type 11: label, we may have to modify coordinates
*	  - type 12: reserved for more labeling options
*	  - type 13: glowlight
*	  - type 14: quadric surface
*	  - type 15: don't apply TMAT to subsequent objects
*	  - type 16: global property on following line
*	  - type 17: vertex colors for previous object
*	  - type 18: vertex transparencies for previous object
*	  - type 19: variant of type 15; forces unitary coordinate sytem
*         - type 0:  no more objects (equivalent to eof)
*
*-----------------------------------------------------------------------------
*
*     Overkill:
      IMPLICIT REAL   (A-H, O-Z)
*
      INCLUDE 'VERSION.incl'
*
*     I/O units for control input, file indirection, data output, info output
      INTEGER STDIN, INPUT0, OUTPUT, NOISE
      PARAMETER (STDIN=5, INPUT0=7, OUTPUT=6, NOISE=0)
      INTEGER LEFT, RIGHT
      PARAMETER (LEFT=1, RIGHT=2)
*
      INTEGER    ILEVEL
*
*     Codes for triangle, sphere, truncated cone, and string of pearls
      INTEGER TRIANG, SPHERE, INTERNAL, CYLIND, CYLFLAT
      INTEGER PLANE, QUADRIC, MXTYPE, FONT, GLOWLIGHT
      INTEGER NORMS, VERTEXRGB, VERTRANSP
      PARAMETER (TRIANG   = 1)
      PARAMETER (SPHERE   = 2)
      PARAMETER (CYLIND   = 3)
      PARAMETER (INTERNAL = 4)
      PARAMETER (CYLFLAT  = 5)
      PARAMETER (PLANE    = 6)
      PARAMETER (NORMS    = 7)
      PARAMETER (MATERIAL = 8)
      PARAMETER (MATEND   = 9)
      PARAMETER (FONT     = 10, LABEL = 11)
      PARAMETER (GLOWLIGHT= 13)
      PARAMETER (QUADRIC  = 14)
      PARAMETER (ISOLATE1 = 15)
      PARAMETER (GPROP    = 16)
      PARAMETER (VERTEXRGB= 17)
      PARAMETER (VERTRANSP= 18)
      PARAMETER (ISOLATE2 = 19)
      PARAMETER (MXTYPE   = 19)
*
*     $$$$$$$$$$$$$   ARRAY SIZE LIMITS $$$$$$$$$$$$$$
      INCLUDE 'parameters.incl'
*
*     $$$$$$$$$$$$$$$$$  END OF LIMITS  $$$$$$$$$$$$$$$$$$$$$$$
*
*
*     Title for run
      CHARACTER*132 TITLE
*
*     Number of tiles
      COMMON /RASTER/ NTX, NTY, NPX, NPY
      INTEGER         NTX, NTY, NPX, NPY
*
*     Pixel averaging scheme
      INTEGER SCHEME
*
*     Background colour
      REAL BKGND(3)
*
*     "Shadow mode?"
      LOGICAL SHADOW
*
*     Phong power
      INTEGER IPHONG
*
*     Straight-on (secondary) light source contribution
      REAL STRAIT
*
*     Ambient light contribution
      REAL AMBIEN
*
*     Specular reflection component
      REAL SPECLR
*
*     Primary light source position
      REAL   SOURCE(3)
*
*     Input transformation
      COMMON /MATRICES/ XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT,
     &                  TMAT, TINV, TINVT, SROT, SRTINV, SRTINVT
     &                 ,RAFTER, TAFTER
      REAL   XCENT, YCENT, SCALE, SXCENT, SYCENT
*     Transformation matrix, inverse, and transposed inverse
      REAL   TMAT(4,4), TINV(4,4), TINVT(4,4)
*     Shortest rotation from light source to +z axis
      REAL   SROT(4,4), SRTINV(4,4), SRTINVT(4,4)
*     Post-hoc transformation on top of original TMAT
      REAL   RAFTER(4,4), TAFTER(3)
      EXTERNAL DET
      REAL     DET
*
*     Distance (in +z) of viewing eye
      REAL   EYEPOS
*
*     Input mode
      INTEGER INMODE
*
*     Buffer one line of input for decoding
      CHARACTER*132 LINE
*
*     Input format(s)
      CHARACTER*80 INFMTS(MXTYPE),INFMT
*
*     Free-format input flag
      LOGICAL INFLGS(MXTYPE),INFLG
*
*     Allow very long names for file indirection
      CHARACTER*132 FULLNAME
*
*     Stuff for shading
c     REAL   NL(3),NORMAL(3),LDOTN
c     REAL RGBCUR(3),RGBSHD(3),RGBFUL(3)
c     REAL SPECOL(3)
*
*     Support for transparency
      REAL OPT(4)
      INTEGER OPT4
*
*     Support for quadric surfaces
      EXTERNAL QINP
      LOGICAL  QINP, ISQUAD
      REAL QTRANS(17)
*
*     Input buffer for details
      REAL   BUF(100)
*
*     Copy of NOISE for ASSERT to see
      INTEGER ASSOUT
      LOGICAL VERBOSE
      COMMON /ASSCOM/ ASSOUT, VERBOSE
      SAVE /ASSCOM/
*
*     The number of "details" each object type is supposed to have
*     :       input,  object, shadow
      INTEGER IDET(MXTYPE), SDET(MXTYPE)
*
c
c
      LOGICAL      HFLAG, XFLAG, SFLAG, SKIP
      CHARACTER*132 FLAGS
      CHARACTER*132 TMPNAM
      INTEGER      LENTMP
*
*     Stuff for labels
      CHARACTER*80  FONTNAME, FONTALIGN
      CHARACTER*128 LABELSTRING
      REAL          FONTSIZE
*
* Support for a "glow" light source
      REAL 	GLOWSRC(3), GLOWCOL(3), GDIST(3), GLOWRAD, GLOW
      INTEGER	GOPT, GPHONG
*
* Support for decompression on the fly
      EXTERNAL ungz
      INTEGER  ungz
*
* Support for BOUNDING_PLANE internal object type
      REAL BPLANE(3), BPNORM(3)
*
*     Keep track of actual coordinate limits (for information only)
      COMMON /NICETIES/ TRULIM,      ZLIM,    FRONTCLIP, BACKCLIP
     &                , ISOLATION
      REAL              TRULIM(3,2), ZLIM(2), FRONTCLIP, BACKCLIP
      INTEGER           ISOLATION

*     Assume no clipping
      BACKCLIP  = -HUGE
      FRONTCLIP =  HUGE

      TRULIM (1,1) = HUGE
      TRULIM (2,1) = HUGE
      TRULIM (3,1) = HUGE
      TRULIM (1,2) = -HUGE
      TRULIM (2,2) = -HUGE
      TRULIM (3,2) = -HUGE
*
      IDET(TRIANG)   = 12
      IDET(SPHERE)   =  7
      IDET(CYLFLAT)  = 11
      IDET(CYLIND)   = 11
      IDET(PLANE)    = 12
      IDET(NORMS )   =  9
      IDET(MATERIAL) = 10
      IDET(LABEL)    =  6
      IDET(GLOWLIGHT)= 10
      IDET(QUADRIC)  = 17
      IDET(VERTEXRGB)=  9
      IDET(VERTRANSP)=  3
      IDET(INTERNAL) = 20

      SDET(TRIANG)   = 13
      SDET(SPHERE)   =  4
      SDET(CYLIND)   =  8
      SDET(QUADRIC)  = 14
      SDET(INTERNAL) = 20
      SDET(PLANE)    =  1
      SDET(NORMS )   =  1
      SDET(MATERIAL) =  1
      SDET(GLOWLIGHT)=  1
      SDET(VERTEXRGB)=  1
      SDET(VERTRANSP)=  1
*
c
c	-h option suppresses header records in output
c	-expand option expands and in-lines all file indirection
c		(and normalizes the in-lined data)
c	-noexpand (the default) simply copies file indirection commands
c		to output file
c	-stereo will create parallel files left.r3d and right.r3d
c	-debug  requests additional output information
c	-angle  specifies angular offset of left/right views from the original
c		e.g. -angle 3.0  sets left eye view to +3 degress, right eye to -3 degrees
c
      HFLAG = .FALSE.
      XFLAG = .FALSE.
      SFLAG = .FALSE.
      skip  = .false.
      nax   = -1
      nay   = -1
      sepang = 0.0
      TMPNAM = '_'
c
c	various tmp variables that gfortran wants to have initialized
      IALIGN = 0
      lentmp = 1
c
c
      i     = 1
      NARG  = IARGC()
   10 continue
      if (i .gt. narg) goto 11
	CALL GETARG(I,FLAGS)
	IF (FLAGS(1:2) .EQ. '-h' .AND. FLAGS(1:5) .NE. '-help') THEN
		HFLAG   = .TRUE.
	ELSE IF (FLAGS(1:4) .EQ. '-exp') THEN
		XFLAG   = .TRUE.
	else if (flags(1:5).eq.'-size') then
                i    = i + 1
                call getarg( i, flags)
                kbrk = 2
                do k = 15,2,-1
                    if (flags(k:k).eq.'x') kbrk = k
                    if (flags(k:k).eq.'X') kbrk = k
                end do
                read (flags(1:kbrk-1),*,err=10,end=10) nax
                read (flags(kbrk+1:15),*,err=10,end=10) nay
	ELSE IF (FLAGS(1:7) .EQ. '-stereo') THEN
		SFLAG   = .TRUE.
		lentmp =1
		IF (I.LT.NARG) THEN
		    CALL GETARG(I+1, FLAGS)
		    IF (FLAGS(1:1).NE.'-') THEN
			do j=1,len(flags)
			    if (flags(j:j).lt.'!') goto 88
			enddo
   88			lentmp = j
			TMPNAM = FLAGS(1:lentmp-1)//'_'
			skip = .true.
		    ENDIF
		ENDIF
		write(0,'(A,A)') 'tmpdir = ',TMPNAM(1:lentmp)
	ELSE IF (FLAGS(1:6) .EQ. '-debug') THEN
		VERBOSE = .TRUE.
	else if (flags(1:4) .eq. '-ang') then
		if (i.lt.narg) then
		    call getarg(i+1, flags)
		    read(flags,'(1f6.0)',end=89,err=89) sepang
		    skip = .true.
		endif
	else if (flags(1:6) .eq. '-label') then
		continue
	else if (skip) then
		skip = .false.
	ELSE
		goto 89
	ENDIF
      i = i + 1
      goto 10
   89	    continue
	    WRITE (NOISE,'(/,A,A)')
     &		'Raster3D Normalization Program ', VERSION
	    WRITE (NOISE,'(A)') 'syntax:'
	    WRITE (NOISE,'(A,A)')
     &		'  normal3d [options] < infile.r3d > outfile.r3d'
     	    WRITE (NOISE,'(4X,A,1X,A)')
     &		'-h              ',
     &			'suppress header records in output',
     &		'-expand         ',
     &			'expand and in-line all file indirection',
     &		'-size HHHxVVV   ',
     &			'set output image size',
     &		'-stereo [tmpdir]',
     &		       'create $$_left.r3d and $$_right.r3d in tmpdir'
     	    CALL EXIT(-1)
c
   11 continue
c
      IF (SFLAG) THEN
	HFLAG = .TRUE.
	OPEN(UNIT=LEFT,FILE=TMPNAM(1:lentmp)//'left.r3d',
     &	     STATUS='UNKNOWN')
	OPEN(UNIT=RIGHT,FILE=TMPNAM(1:lentmp)//'right.r3d',
     &	     STATUS='UNKNOWN')
      ENDIF
*
*     Copy the info (also error reporting) unit number to common
      ASSOUT = NOISE
      WRITE (NOISE,*) '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%',
     &                '%%%%%%%%%%%%%%%%%%%%%%%%%%'
      WRITE (NOISE,*) '%             Raster3D normalization ',
     &                'program ',VERSION,'          %'
      WRITE (NOISE,*) '%             -----------------------',
     &                '-------------             %'
      WRITE (NOISE,*) '% If you publish figures generated by this ',
     &                'program please cite %'
      WRITE (NOISE,*) '%   Merritt & Bacon (1997)  ',
     &                'Meth. Enzymol. 277, 505-524.','       %'
      WRITE (NOISE,*) '%             -----------------------',
     &                '-------------             %'
      WRITE (NOISE,*) '% comments & suggestions to:  ',
     &                '  merritt@u.washington.edu','       %'
      WRITE (NOISE,*) '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%',
     &                '%%%%%%%%%%%%%%%%%%%%%%%%%%'
*
*     Ready for input records
      ILEVEL = 0
      INPUT  = STDIN
      ISOLATION = 0
*
*     Get title
  100 CONTINUE
      READ (INPUT,1) TITLE
1     FORMAT (A)
      IF (TITLE(1:1) .EQ. '#') THEN
        IF (.NOT.HFLAG) WRITE(OUTPUT,1) TITLE
	GOTO 100
      ENDIF
*
*     2.4h - allow file indirection for header
      J = 1
      K = 132
      L = 132
      IF (TITLE(1:1) .EQ. '@') THEN
	DO I=132,2,-1
	  IF (TITLE(I:I).NE.' ') J = I
	ENDDO
	OPEN (UNIT=INPUT0,ERR=101,STATUS='OLD',FILE=TITLE(J:132))
	WRITE (NOISE,'(A,A)') '  + Opening input file ',TITLE(J:132)
	INPUT = INPUT0
	ILEVEL = 1
	READ (INPUT,'(A)',ERR=101) TITLE
	IF (TITLE(1:1).EQ.'#') GOTO 100
	GOTO 102
  101	WRITE (NOISE,'(A,A)') ' >> Cannot open or read file ',TITLE(2:132)
	CALL EXIT(-1)
  102	CONTINUE
      ENDIF
*
      DO K = 132,1,-1
        IF (TITLE(K:K).NE.' ') GOTO 103
      ENDDO
  103 CONTINUE
      IF (.NOT.HFLAG) WRITE(OUTPUT,1) TITLE(1:K)
      IF (SFLAG) WRITE(LEFT,1)  TITLE(1:K)
      IF (SFLAG) WRITE(RIGHT,1) TITLE(1:K)
*
*     Get number of tiles
      READ (INPUT,1,END=104) LINE
      READ (LINE,*,ERR=104) NTX,NTY
      CALL ASSERT (NTX.GT.0, 'ntx.le.0')
      CALL ASSERT (NTY.GT.0, 'nty.le.0')
*     Get number of pixels per tile
      READ (INPUT,1,END=104) LINE
      READ (LINE,*,ERR=104) NPX,NPY
*     Get pixel averaging scheme
      READ (INPUT,1,END=104) LINE
      READ (LINE,*,ERR=104) SCHEME
      CALL ASSERT (SCHEME.GE.0 .AND. SCHEME.LE.4, 'bad scheme')
      GOTO 105
104   CALL ASSERT(.FALSE.,
     &           '>>> This doesnt look like a Raster3D input file! <<<')
105   CONTINUE
*
*     Let render autotile it if npx=0 or -size on command line
      if (nax.gt.0 .or. nay.gt.0) then
        if (scheme.eq.3) scheme = 4
      	ntx = nax
	nty = nay
	npx = 0
	npy = 0
      endif
*
22    format(2I6)
      if (.not.hflag) then
      	write (output,22) ntx, nty
	write (output,22) npx, npy
	write (output,22) scheme
      endif
      if (sflag) then
      	write (left,22)   ntx, nty
	write (left,22)   npx, npy
	write (left,22)   scheme
      	write (right,22)  ntx, nty
	write (right,22)  npx, npy
	write (right,22)  scheme
      endif
*
*     Some derived parameters
      if (npx.eq.0) npx = 1
      if (npy.eq.0) npy = 1
      XCENT = NTX*NPX/2.
      YCENT = NTY*NPY/2.
      SCALE = 2.*MIN(XCENT,YCENT)
*
*     Get background colour
      READ (INPUT,1) LINE
      READ (LINE,*) BKGND
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) WRITE (LEFT,1)  LINE
      IF (SFLAG) WRITE (RIGHT,1) LINE
      CALL ASSERT (BKGND(1).GE.0., 'bkgnd(1) < 0')
      CALL ASSERT (BKGND(2).GE.0., 'bkgnd(2) < 0')
      CALL ASSERT (BKGND(3).GE.0., 'bkgnd(3) < 0')
      CALL ASSERT (BKGND(1).LE.1., 'bkgnd(1) > 1')
      CALL ASSERT (BKGND(2).LE.1., 'bkgnd(2) > 1')
      CALL ASSERT (BKGND(3).LE.1., 'bkgnd(3) > 1')
*
*     Get "shadows" flag
      READ (INPUT,1) LINE
      READ (LINE,*) SHADOW
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) WRITE (LEFT,1)  LINE
      IF (SFLAG) WRITE (RIGHT,1) LINE
*
*     Get Phong power
      READ (INPUT,1) LINE
      READ (LINE,*) PHONG
      IPHONG = PHONG
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) WRITE (LEFT,1)  LINE
      IF (SFLAG) WRITE (RIGHT,1) LINE
      CALL ASSERT (IPHONG.GE.0, 'iphong < 0')
*
*     Get contribution of straight-on (secondary) light source
      READ (INPUT,1) LINE
      READ (LINE,*) STRAIT
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) WRITE (LEFT,1)  LINE
      IF (SFLAG) WRITE (RIGHT,1) LINE
      CALL ASSERT (STRAIT.GE.0., 'strait < 0')
      CALL ASSERT (STRAIT.LE.1., 'strait > 1')
*
*     Derive contribution of primary light source
      PRIMAR = 1. - STRAIT
*
*     Get contribution of ambient light
      READ (INPUT,1) LINE
      READ (LINE,*) AMBIEN
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) WRITE (LEFT,1)  LINE
      IF (SFLAG) WRITE (RIGHT,1) LINE
      CALL ASSERT (AMBIEN.GE.0., 'ambien < 0')
      CALL ASSERT (AMBIEN.LE.1., 'ambien > 1')
*
*     Get component of specular reflection
      READ (INPUT,1) LINE
      READ (LINE,*) SPECLR
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) WRITE (LEFT,1)  LINE
      IF (SFLAG) WRITE (RIGHT,1) LINE
      CALL ASSERT (SPECLR.GE.0., 'speclr < 0')
      CALL ASSERT (SPECLR.LE.1., 'speclr > 1')
*
*     Derive component of diffuse reflection
      CALL ASSERT (AMBIEN+SPECLR.LE.1., 'ambien+speclr > 1')
      DIFFUS = 1. - (AMBIEN+SPECLR)
*
*     Note distance of viewing eye, but don't apply it here
*     Force it to 0 (no perspective) for stereo
      READ (INPUT,1) LINE
      READ (LINE,*) EYEPOS
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) THEN
 	WRITE (LEFT,1)  '0.0	Stereo is better with no perspective'
	WRITE (RIGHT,1) '0.0	Stereo is better with no perspective'
      ENDIF
      CALL ASSERT (EYEPOS.GE.0., 'eyepos.lt.0')
      EYEPOS = 0.0
*
*     Get position of primary light source
      READ (INPUT,1) LINE
      READ (LINE,*) SOURCE
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      SMAG = SQRT(SOURCE(1)**2 + SOURCE(2)**2 + SOURCE(3)**2)
      SOURCE(1) = SOURCE(1) / SMAG
      SOURCE(2) = SOURCE(2) / SMAG
      SOURCE(3) = SOURCE(3) / SMAG
*
*     Get input transformation
      IF (VERBOSE) WRITE (NOISE,*) 'tmat (v'' = v * tmat):'
      DO I=1,4
        READ (INPUT,*) (TMAT(I,J),J=1,4)
        IF (VERBOSE) WRITE (NOISE,*) (TMAT(I,J),J=1,4)
      END DO
      IF (.NOT.HFLAG) THEN
	WRITE (OUTPUT,*) ' 1. 0. 0.   0.'
      	WRITE (OUTPUT,*) ' 0. 1. 0.   0.'
      	WRITE (OUTPUT,*) ' 0. 0. 1.   0.'
      	WRITE (OUTPUT,*) ' 0. 0. 0.   1.'
      ENDIF
      IF (SFLAG) THEN
c	[-angle AA] forces left/right headers with angular offset
      	if (sepang .gt. 0) then
	  write (noise,12)
     &        ' stereo separation angle +/-',sepang,' degrees'
12	  format(a,1x,1f6.2,a)
	  cossep = cos(sepang*0.017453293)
	  sinsep = sin(sepang*0.017453293)
c	  Counter-rotate light source so that both views have same illumination
	  x = source(1)*cossep - source(3)*sinsep
	  y = source(2)
	  z = source(1)*sinsep + source(3)*cossep
	  write (right,14) x,y,z,'Primary light source'
	  x =  source(1)*cossep + source(3)*sinsep
	  z = -source(1)*sinsep + source(3)*cossep
	  write (left,14)  x,y,z,'Primary light source'
13	  format(1x,f9.5,1x,f4.1,1x,f9.5,3x,f4.1,5x,a)
14	  format(1x,3f8.4,12x,a)
	  write (left,13)  cossep, 0., -sinsep, 0., 'left eye view'
	  write (left,13)  0.,     1.,     0., 0.
	  write (left,13)  sinsep, 0.,  cossep, 0.
	  write (left,13) 0., 0., 0., 1.0
	  write (right,13)  cossep, 0.,  sinsep, 0., 'right eye view'
	  write (right,13)  0.,     1.,      0., 0.
	  write (right,13) -sinsep, 0.,  cossep, 0.
	  write (right,13) 0., 0., 0., 1.0
	else
c	Otherwise left/right headers differ by a shear operation
	  write (LEFT,14)source(1),source(2),source(3),'Primary light'
	  WRITE (LEFT,*)  ' 1.   0. 0.   0.'
      	  WRITE (LEFT,*)  ' 0.   1. 0.   0.'
      	  WRITE (LEFT,*)  ' 0.03 0. 1.   0.         Left eye view'
      	  WRITE (LEFT,*)  ' 0.   0. 0.   1.'
	  write (RIGHT,14)source(1),source(2),source(3),'Primary light'
	  WRITE (RIGHT,*) ' 1.   0. 0.   0.'
      	  WRITE (RIGHT,*) ' 0.   1. 0.   0.'
      	  WRITE (RIGHT,*) '-0.03 0. 1.   0.         Right eye view'
      	  WRITE (RIGHT,*) ' 0.   0. 0.   1.'
	endif
      ENDIF
*
*     By popular demand, add a post-hoc rotation/translation option
*     that uses matrices of the form used by O and molscript
*     Initialized here to identity matrix; set by GPROP options.
      DO I = 1,4
      DO J = 1,4
        RAFTER(I,J) = 0.0
      ENDDO
      RAFTER(I,I) = 1.0
      TAFTER(I)   = 0.0
      ENDDO
*
*     Compute the rotation matrix which takes the light
*     source to the +z axis (i.e., to the viewpoint).
*     first make p = source cross z (and normalize p)
      P1 = SOURCE(2)
      P2 = -SOURCE(1)
*     p3 = 0
      PLEN = SQRT(P1**2 + P2**2)
      IF (PLEN .GT. 0.0) P1 = P1 / PLEN
      IF (PLEN .GT. 0.0) P2 = P2 / PLEN
*     phi is the angle between source and z (shortest route)
      COSPHI = SOURCE(3)
      SINPHI = PLEN
      SROT(1,1) = P1**2 + (1.-P1**2)*COSPHI
      SROT(1,2) = P1*P2*(1.-COSPHI)
      SROT(1,3) = P2*SINPHI
      SROT(2,1) = SROT(1,2)
      SROT(2,2) = P2**2 + (1.-P2**2)*COSPHI
      SROT(2,3) = -P1*SINPHI
      SROT(3,1) = -SROT(1,3)
      SROT(3,2) = -SROT(2,3)
      SROT(3,3) = COSPHI
      SROT(1,4) = 0.0
      SROT(2,4) = 0.0
      SROT(3,4) = 0.0
      SROT(4,1) = 0.0
      SROT(4,2) = 0.0
      SROT(4,3) = 0.0
      SROT(4,4) = 1.0
*
*     Quadrics will require the inverse matrix also (and its transpose)
      CALL QSETUP
*
*     Get input mode
      READ (INPUT,1) LINE
      READ (LINE,*) INMODE
      IF (.NOT.HFLAG) WRITE (OUTPUT,1) LINE
      IF (SFLAG) WRITE (LEFT,1)  LINE
      IF (SFLAG) WRITE (RIGHT,1) LINE
      CALL ASSERT (INMODE.GE.1.,'bad inmode')
      IF (INMODE.GT.3) WRITE (NOISE,*) 'Non-standard INMODE',INMODE
*
*     Get input format(s)
      IF (INMODE.EQ.1.OR.INMODE.EQ.2) THEN
        READ (INPUT,'(A)') INFMT
        IF (.NOT.HFLAG) WRITE (OUTPUT,'(A1)') '*'
        IF (SFLAG) WRITE (LEFT, '(A1)') '*'
        IF (SFLAG) WRITE (RIGHT,'(A1)') '*'
        II = 0
2       CONTINUE
        IF (INFMT(1:1).EQ.' ') THEN
          INFMT(1:79) = INFMT(2:80)
          INFMT(80:80) = ' '
          II = II + 1
          IF (II.LT.80) GO TO 2
        ENDIF
        IF (INFMT(1:1).EQ.'*') THEN
          INFLG = .TRUE.
        ELSE
          INFLG = .FALSE.
        ENDIF
      ELSEIF (INMODE.GE.3) THEN
        DO 4 I=1,3
          READ (INPUT,'(A)') INFMTS(I)
          IF (.NOT.HFLAG) WRITE (OUTPUT,'(A1)') '*'
          IF (SFLAG) WRITE (LEFT, '(A1)') '*'
          IF (SFLAG) WRITE (RIGHT,'(A1)') '*'
          II = 0
3         CONTINUE
          IF (INFMTS(I)(1:1).EQ.' ') THEN
            INFMTS(I)(1:79) = INFMTS(I)(2:80)
            INFMTS(I)(80:80) = ' '
            II = II + 1
            IF (II.LT.80) GO TO 3
          ENDIF
          IF (INFMTS(I)(1:1).EQ.'*') THEN
            INFLGS(I) = .TRUE.
          ELSE
            INFLGS(I) = .FALSE.
          ENDIF
4       CONTINUE
	INFLGS(PLANE)     = INFLGS(TRIANG)
	INFMTS(PLANE)     = INFMTS(TRIANG)
	INFLGS(NORMS)     = INFLGS(TRIANG)
	INFMTS(NORMS)     = INFMTS(TRIANG)
	INFLGS(VERTEXRGB) = INFLGS(TRIANG)
	INFMTS(VERTEXRGB) = INFMTS(TRIANG)
	INFLGS(VERTRANSP) = INFLGS(TRIANG)
	INFMTS(VERTRANSP) = INFMTS(TRIANG)
	INFLGS(MATERIAL)  = .TRUE.
	INFLGS(FONT)      = .TRUE.
	INFLGS(LABEL)     = .TRUE.
	INFLGS(GLOWLIGHT) = .TRUE.
 	INFLGS(QUADRIC)   = .TRUE.
      ELSE
        CALL ASSERT (.FALSE.,'crash 4')
      ENDIF
*
      IF (SFLAG) CLOSE(LEFT)
      IF (SFLAG) CLOSE(RIGHT)
c
c     Done with header records
c     As of V2.5e, keep reading until file ends
c     >>> This is a change <<<
c
c     IF (INPUT.NE.STDIN) THEN
c	CLOSE(INPUT)
c	INPUT = STDIN
c     ENDIF
*
*
c
      npropm  = 0
      ntransp = 0
      nsphere = 0
      ncylind = 0
      nplanes = 0
      ntriang = 0
      nquads  = 0
      nlabels = 0
c
c     Objects in, and count up objects that may impinge on each tile
      NDET = 0
      MDET = 0
      N = 0
c
c     Read in next object
7     CONTINUE
      IF (INMODE.EQ.1.OR.INMODE.EQ.2) THEN
        INTYPE = INMODE
	GOTO 8
      ENDIF
c     Aug 1996 - allow file indirection
      READ (INPUT,'(A)',END=50) LINE
      IF (LINE(1:1) .EQ. '#') THEN
	WRITE (OUTPUT,1) LINE
	GOTO 7
      ELSE IF (LINE(1:1) .NE. '@') THEN
 	READ (LINE,*,END=50) INTYPE
      ELSE IF (.NOT.XFLAG) THEN
	WRITE (OUTPUT,1) LINE
	GOTO 7
      ELSE
 	CALL ASSERT(ILEVEL.LT.MAXLEV,
     &	            'Too many levels of indirection')
     	J = 1
	K = 132
	L = 132
 	DO I=132,2,-1
	  IF (LINE(I:I).NE.' ') J = I
	  IF (LINE(I:I).EQ.'#') K = I-1
	  IF (LINE(I:I).EQ.'!') K = I-1
	  IF (LINE(I:I).EQ.CHAR(0)) K = I-1
	  IF (LINE(I:I).EQ.'	') LINE(I:I) = ' '
 	ENDDO
	IF (J.EQ.1) GOTO 74
	DO I=J,K
	  IF (LINE(I:I).NE.' ') L = I
	ENDDO
	K = L
	IF (LINE(K:K).EQ.'Z' .or. LINE(K-1:K).eq.'gz') THEN
cdebug
cdebug	    ungz will uncompress into a temporary file, which ought to be
cdebug	    deleted later.  Unfortunately, that's hard to do in g77, since
cdebug	    it doesn't support dispose='DELETE'.
	    line(k+1:k+1) = char(0)
	    if (0 .gt. ungz( line(j:k+1), fullname )) goto 74
	    j = 1
	    k = 132
	    do i=132,2,-1
	      if (fullname(i:i).eq.' ')     k = i-1
	      if (fullname(i:i).eq.char(0)) k = i-1
	    enddo
	    if (verbose)
     &		write(noise,*) 'Creating temporary file: ',fullname(j:k)
	    open (unit=input0+ilevel,err=74,status='OLD',
     &		  file=fullname(j:k))
	    fullname = line(2:132)
	    goto 72
cdebug
	ENDIF
   70	CONTINUE
	OPEN (UNIT=INPUT0+ILEVEL,ERR=71,STATUS='OLD',
     &	      FILE=LINE(J:K))
	FULLNAME = LINE(J:K)
	GOTO 72
   71	CONTINUE
	IF (LINE(K-3:K).NE.'.r3d') THEN
	    K = K + 4
	    LINE(K-3:K) = '.r3d'
	    GOTO 70
	ENDIF
	CALL LIBLOOKUP( LINE(J:K), FULLNAME )
	OPEN (UNIT=INPUT0+ILEVEL,ERR=74,STATUS='OLD',FILE=FULLNAME)
   72	CONTINUE
	DO I = 132,2,-1
	  IF (FULLNAME(I:I).EQ.' ') J = I
	ENDDO
 	WRITE (NOISE,'(A,A)') '  + Opening input file ',FULLNAME(1:J)
	INPUT  = INPUT0+ILEVEL
 	ILEVEL = ILEVEL + 1
 	GOTO 7
   74	WRITE (NOISE,'(A,A)') ' >> Cannot open file ',LINE(J:K)
 	GOTO 7
      ENDIF
c
      IF (INTYPE.EQ.0) GO TO 50
      	IF (INTYPE .EQ. MATEND) THEN
	    WRITE (OUTPUT,1) LINE
	    ISOLATION = 0
	    GOTO 7
	ELSE
	    WRITE (OUTPUT,'(I2)') INTYPE
	END IF
	IF (INTYPE.EQ.CYLFLAT) INTYPE = CYLIND
        CALL ASSERT (INTYPE.GE.1.AND.INTYPE.LE.MXTYPE,'bad object')
        CALL ASSERT (INTYPE.NE.INTERNAL,'Object type 4 not supported')
c
8     CONTINUE
        INFMT = INFMTS(INTYPE)
        INFLG = INFLGS(INTYPE)
c
c     handle non-numerical input elsewhere
      IF (INTYPE.EQ.FONT) THEN
	GOTO 9
      ELSE IF (INTYPE.EQ.GPROP) THEN
	GOTO 9
      ELSE IF (INTYPE.EQ.ISOLATE1) THEN
	ISOLATION = 1
	GOTO 7
      ELSE IF (INTYPE.EQ.ISOLATE2) THEN
	ISOLATION = 2
	GOTO 7
c
      ELSE IF (INFLG) THEN
        READ (INPUT,*,END=50) (BUF(I),I=1,IDET(INTYPE))
      ELSE
        READ (INPUT,INFMT,END=50) (BUF(I),I=1,IDET(INTYPE))
      ENDIF
*     Allow an all-zeroes record to terminate input for the
*     benefit of those of us who might inadvertently supply
*     a series of blank records after our real input as a
*     side-effect of tape blocking or sloppiness or ...
*     15-Dec-1999  Oops!  all zeros is legal input for [at least] LABEL
      IF (INTYPE.EQ.LABEL) goto 9
      DO I=1,IDET(INTYPE)
        IF (BUF(I).NE.0.) GO TO 9
      ENDDO
      GO TO 50
9     CONTINUE
      N = N + 1
*     From this point on, we'll use the symbolic codes for objects
      IF (INTYPE.EQ.TRIANG .or. INTYPE.EQ.PLANE) THEN
*       triangle as read in
	IF (INTYPE.EQ.TRIANG) NTRIANG = NTRIANG + 1
	IF (INTYPE.EQ.PLANE)  NPLANE  = NPLANE  + 1
	NDET = NDET + IDET(INTYPE)
	MDET = MDET + SDET(INTYPE)
        X1A = BUF(1)
        Y1A = BUF(2)
        Z1A = BUF(3)
        X2A = BUF(4)
        Y2A = BUF(5)
        Z2A = BUF(6)
        X3A = BUF(7)
        Y3A = BUF(8)
        Z3A = BUF(9)
        RED = BUF(10)
        GRN = BUF(11)
        BLU = BUF(12)
	CALL CHKRGB( RED,GRN,BLU,'invalid triangle color')
        CALL ASSERT (IDET(INTYPE).EQ.12,'idet(1).ne.12')
*	Isolated objects not transformed by TMAT
	IF (ISOLATION.EQ.0) THEN
*	update true coordinate limits
	  TRULIM(1,1) = MIN( TRULIM(1,1), X1A,X2A,X3A)
	  TRULIM(1,2) = MAX( TRULIM(1,2), X1A,X2A,X3A)
	  TRULIM(2,1) = MIN( TRULIM(2,1), Y1A,Y2A,Y3A)
	  TRULIM(2,2) = MAX( TRULIM(2,2), Y1A,Y2A,Y3A)
	  TRULIM(3,1) = MIN( TRULIM(3,1), Z1A,Z2A,Z3A)
	  TRULIM(3,2) = MAX( TRULIM(3,2), Z1A,Z2A,Z3A)
*       modify the input, so to speak
          CALL TRANSF (X1A,Y1A,Z1A)
          CALL TRANSF (X2A,Y2A,Z2A)
          CALL TRANSF (X3A,Y3A,Z3A)
	ENDIF
*       write it back out again
        WRITE (OUTPUT,91) X1A,Y1A,Z1A, X2A,Y2A,Z2A, X3A,Y3A,Z3A,
     &                    RED,GRN,BLU
91      FORMAT( 3F10.5,1X,3F10.5,1X,3F10.5,1X,3F6.3 )
      ELSEIF (INTYPE.EQ.SPHERE) THEN
*       sphere as read in
	NSPHERE = NSPHERE + 1
	NDET = NDET + IDET(INTYPE)
	MDET = MDET + SDET(INTYPE)
        XA = BUF(1)
        YA = BUF(2)
        ZA = BUF(3)
        RA = BUF(4)
        RED = BUF(5)
        GRN = BUF(6)
        BLU = BUF(7)
	CALL CHKRGB( RED,GRN,BLU,'invalid sphere color')
        CALL ASSERT (IDET(INTYPE).EQ.7,'idet(2).ne.7')
*	Isolated objects not transformed by TMAT
	IF (ISOLATION.EQ.0) THEN
*	update true coordinate limits
	  TRULIM(1,1) = MIN( TRULIM(1,1), XA )
	  TRULIM(1,2) = MAX( TRULIM(1,2), XA )
	  TRULIM(2,1) = MIN( TRULIM(2,1), YA )
	  TRULIM(2,2) = MAX( TRULIM(2,2), YA )
	  TRULIM(3,1) = MIN( TRULIM(3,1), ZA )
	  TRULIM(3,2) = MAX( TRULIM(3,2), ZA )
*       modify the input, as it were
          CALL TRANSF (XA,YA,ZA)
          RA = RA / TMAT(4,4)
	ENDIF
*       write it back out again
	WRITE (OUTPUT,92) XA,YA,ZA, RA, RED,GRN,BLU
92      FORMAT( 3F10.5,1X,F10.5,1X,3F6.3 )
      ELSEIF (INTYPE.EQ.CYLIND) THEN
	NCYLIND = NCYLIND + 1
	NDET = NDET + IDET(INTYPE)
	MDET = MDET + SDET(INTYPE)
        X1A = BUF(1)
        Y1A = BUF(2)
        Z1A = BUF(3)
	R1A = BUF(4)
        X2A = BUF(5)
        Y2A = BUF(6)
        Z2A = BUF(7)
	R2A = R1A
        RED = BUF(9)
        GRN = BUF(10)
        BLU = BUF(11)
	CALL CHKRGB( RED,GRN,BLU,'invalid cylinder color')
        CALL ASSERT (IDET(INTYPE).EQ.11,'idet(1).ne.11')
*	Isolated objects not transformed by TMAT
	IF (ISOLATION.EQ.0) THEN
*	update true coordinate limits
	  TRULIM(1,1) = MIN( TRULIM(1,1), X1A,X2A)
	  TRULIM(1,2) = MAX( TRULIM(1,2), X1A,X2A)
	  TRULIM(2,1) = MIN( TRULIM(2,1), Y1A,Y2A)
	  TRULIM(2,2) = MAX( TRULIM(2,2), Y1A,Y2A)
	  TRULIM(3,1) = MIN( TRULIM(3,1), Z1A,Z2A)
	  TRULIM(3,2) = MAX( TRULIM(3,2), Z1A,Z2A)
*       modify the input, so to speak
          CALL TRANSF (X1A,Y1A,Z1A)
          CALL TRANSF (X2A,Y2A,Z2A)
          R1A = R1A / TMAT(4,4)
          R2A = R2A / TMAT(4,4)
	ENDIF
*       write it back out again
        WRITE (OUTPUT,93) X1A,Y1A,Z1A, R1A, X2A,Y2A,Z2A, R2A,
     &                    RED,GRN,BLU
93      FORMAT ( 3F10.5,1X,F10.5,1X,3F10.5,1X,F10.5,1X,3F6.3 )
      ELSEIF (INTYPE.EQ.NORMS) THEN
*	vertex normals as given (these belong to previous triangle)
	NNORMS = NNORMS + 1
	NDET = NDET + IDET(INTYPE)
	MDET = MDET + SDET(INTYPE)
        X1A = BUF(1)
        Y1A = BUF(2)
        Z1A = BUF(3)
        X2A = BUF(4)
        Y2A = BUF(5)
        Z2A = BUF(6)
        X3A = BUF(7)
        Y3A = BUF(8)
        Z3A = BUF(9)
	IF (ISOLATION.EQ.0) THEN
*	  Apply rotation matrix, but not translation components
	  X1B = X1A*TMAT(1,1) + Y1A*TMAT(2,1) + Z1A*TMAT(3,1)
	  Y1B = X1A*TMAT(1,2) + Y1A*TMAT(2,2) + Z1A*TMAT(3,2)
	  Z1B = X1A*TMAT(1,3) + Y1A*TMAT(2,3) + Z1A*TMAT(3,3)
	  X2B = X2A*TMAT(1,1) + Y2A*TMAT(2,1) + Z2A*TMAT(3,1)
	  Y2B = X2A*TMAT(1,2) + Y2A*TMAT(2,2) + Z2A*TMAT(3,2)
	  Z2B = X2A*TMAT(1,3) + Y2A*TMAT(2,3) + Z2A*TMAT(3,3)
	  X3B = X3A*TMAT(1,1) + Y3A*TMAT(2,1) + Z3A*TMAT(3,1)
	  Y3B = X3A*TMAT(1,2) + Y3A*TMAT(2,2) + Z3A*TMAT(3,2)
	  Z3B = X3A*TMAT(1,3) + Y3A*TMAT(2,3) + Z3A*TMAT(3,3)
*	  Also apply post-rotation, if any
	  X1A = RAFTER(1,1)*X1B + RAFTER(1,2)*Y1B + RAFTER(1,3)*Z1B
	  Y1A = RAFTER(2,1)*X1B + RAFTER(2,2)*Y1B + RAFTER(2,3)*Z1B
	  Z1A = RAFTER(3,1)*X1B + RAFTER(3,2)*Y1B + RAFTER(3,3)*Z1B
	  X2A = RAFTER(1,1)*X2B + RAFTER(1,2)*Y2B + RAFTER(1,3)*Z2B
	  Y2A = RAFTER(2,1)*X2B + RAFTER(2,2)*Y2B + RAFTER(2,3)*Z2B
	  Z2A = RAFTER(3,1)*X2B + RAFTER(3,2)*Y2B + RAFTER(3,3)*Z2B
	  X3A = RAFTER(1,1)*X3B + RAFTER(1,2)*Y3B + RAFTER(1,3)*Z3B
	  Y3A = RAFTER(2,1)*X3B + RAFTER(2,2)*Y3B + RAFTER(2,3)*Z3B
	  Z3A = RAFTER(3,1)*X3B + RAFTER(3,2)*Y3B + RAFTER(3,3)*Z3B
	ENDIF
*       write it back out again
	WRITE (OUTPUT,91) X1A,Y1A,Z1A, X2A,Y2A,Z2A, X3A,Y3A,Z3A
*
*	Vertex colors for preceding triangle
*	(no transformation needed)
*
      ELSEIF (INTYPE .EQ. VERTEXRGB) THEN
	NDET = NDET + IDET(INTYPE)
	MDET = MDET + SDET(INTYPE)
	CALL CHKRGB( BUF(1),BUF(2),BUF(3),'invalid vertex color')
	CALL CHKRGB( BUF(4),BUF(5),BUF(6),'invalid vertex color')
	CALL CHKRGB( BUF(7),BUF(8),BUF(9),'invalid vertex color')
	WRITE (OUTPUT,91) BUF(1),BUF(2),BUF(3),BUF(4),BUF(5),BUF(6),
     &	                  BUF(7),BUF(8),BUF(9)
*
      ELSEIF (INTYPE .EQ. VERTRANSP) THEN
	NDET = NDET + IDET(INTYPE)
	MDET = MDET + SDET(INTYPE)
	WRITE (OUTPUT,91) BUF(1),BUF(2),BUF(3)
*
*	Material properties are saved with no further manipulation
*
      ELSEIF (INTYPE .EQ. MATERIAL) THEN
	NPROPM = NPROPM + 1
	NDET = NDET + IDET(INTYPE)
	MDET = MDET + SDET(INTYPE)
	NBOUNDS = 0
	SPHONG = BUF(1)
	SSPEC  = BUF(2)
	SR     = BUF(3)
	SG     = BUF(4)
	SB     = BUF(5)
	CLRITY = BUF(6)
	OPT(1) = BUF(7)
	OPT(2) = BUF(8)
	OPT(3) = BUF(9)
	OPT(4) = BUF(10)
	WRITE (OUTPUT,94) SPHONG, SSPEC, SR,SG,SB, CLRITY,
     &                    OPT(1),OPT(2),OPT(3),OPT(4)
94      FORMAT (F5.0,1X,F5.2,1X,3F7.3,1X,F6.3,3X,4F6.1)
*	24-Feb-1997 OPT(4) signals additional MATERIAL records
	OPT4 = OPT(4)
	IF (OPT4.GT.0) THEN
	  L = 1
	  DO I = 1, OPT4
            READ (INPUT,'(A)',END=50) LINE
	    DO J = 132, 1, -1
	      IF (LINE(J:J).NE.' '.AND.LINE(J:J).NE.'	') L = J
	    ENDDO
	    IF (LINE(L:L+8).EQ.'FRONTCLIP') THEN
	      READ(LINE(L+10:132),*) ZCLIP
	      ZCLIP = ZCLIP / TMAT(4,4)
	      WRITE(OUTPUT,'(A9,1X,F9.3)') 'FRONTCLIP',ZCLIP
	    ELSE IF (LINE(L:L+7).EQ.'BACKCLIP') THEN
	      READ(LINE(L+9:132),*) ZCLIP
	      ZCLIP = ZCLIP / TMAT(4,4)
	      WRITE(OUTPUT,'(A8,2X,F9.3)') 'BACKCLIP',ZCLIP
	    ELSE IF (LINE(L:L+13).EQ.'BOUNDING_PLANE') THEN
	      NBOUNDS = NBOUNDS + 1
	      READ (LINE(L+15:132),*) IBPTYPE,XB,YB,ZB,xn,yn,zn
	      CALL TRANSF(XB,YB,ZB)
	      xnb = xn*TMAT(1,1) + yn*TMAT(2,1) + zn*TMAT(3,1)
              ynb = xn*TMAT(1,2) + yn*TMAT(2,2) + zn*TMAT(3,2)
              znb = xn*TMAT(1,3) + yn*TMAT(2,3) + zn*TMAT(3,3)
              xn = RAFTER(1,1)*xnb + RAFTER(1,2)*ynb + RAFTER(1,3)*znb
              yn = RAFTER(2,1)*xnb + RAFTER(2,2)*ynb + RAFTER(2,3)*znb
              zn = RAFTER(3,1)*xnb + RAFTER(3,2)*ynb + RAFTER(3,3)*znb
              temp = sqrt(xn*xn + yn*yn + zn*zn)
              xn = xn/temp
              yn = yn/temp
              zn = zn/temp
	      write(output,'(A14,I3,3(1X,F10.5),3F9.5)')
     &		'BOUNDING_PLANE',ibptype,xb,yb,zb,xn,yn,zn
	    ELSE
	      WRITE(OUTPUT,1) LINE
	    ENDIF
	  ENDDO
	ENDIF
	NDET = NDET + NBOUNDS*IDET(INTERNAL)
	MDET = MDET + NBOUNDS*SDET(INTERNAL)
*
*     Font alignment options:
*	C - centered, have to transform coords
*	L - left,     ""
*	R - right,    ""
*	O - offset,   leave font offsets alone!
      ELSEIF (INTYPE .EQ. FONT) THEN
        READ (INPUT,'(A)',END=50) LINE
	READ (LINE,*) FONTNAME, FONTSIZE, FONTALIGN
	IF (FONTALIGN(1:1).EQ.'C') THEN
	    IALIGN=1
	ELSE IF (FONTALIGN(1:1).EQ.'R') THEN
	    IALIGN=2
	ELSE IF (FONTALIGN(1:1).EQ.'O') THEN
	    IALIGN=3
	ELSE
	    IALIGN=0
	ENDIF
	WRITE(OUTPUT,1) LINE
	GOTO 7
      ELSEIF (INTYPE .EQ. LABEL ) THEN
	READ (INPUT,702,END=50) LABELSTRING
702	FORMAT(A)
	nlabels = nlabels + 1
        XA = BUF(1)
        YA = BUF(2)
        ZA = BUF(3)
	IF (ISOLATION.EQ.0) THEN
          IF (IALIGN.NE.3) CALL TRANSF (XA,YA,ZA)
	ENDIF
        RED = BUF(4)
        GRN = BUF(5)
        BLU = BUF(6)
	CALL CHKRGB( RED,GRN,BLU,'invalid label color')
	WRITE (OUTPUT,801) XA,YA,ZA, RED,GRN,BLU
801	FORMAT(3f10.4,2x,3f6.3)
	WRITE (OUTPUT,1) LABELSTRING
	GOTO 7

      ELSEIF (INTYPE .EQ. GLOWLIGHT) THEN
 	GLOWSRC(1) = BUF(1)
 	GLOWSRC(2) = BUF(2)
 	GLOWSRC(3) = BUF(3)
 	GLOWRAD    = BUF(4)
 	GLOW       = BUF(5)
 	GOPT       = BUF(6)
 	GPHONG     = BUF(7)
*	Isolated objects not transformed by TMAT
	IF (ISOLATION.EQ.0) THEN
 	  CALL TRANSF(GLOWSRC(1),GLOWSRC(2),GLOWSRC(3))
 	  GLOWRAD = GLOWRAD/TMAT(4,4)
	ENDIF
 	RED = BUF(8)
 	GRN = BUF(9)
 	BLU = BUF(10)
	CALL CHKRGB( RED,GRN,BLU,'invalid glow light color')
 	WRITE (OUTPUT,802) GLOWSRC,GLOWRAD,GLOW,GOPT,GPHONG,RED,GRN,BLU
802	FORMAT(4f10.4,1x,f4.2,1x,i4,1x,i4,2x,3f6.3)
 	GOTO 7
*
      ELSEIF (INTYPE.EQ.QUADRIC) THEN
 	NQUADS = NQUADS + 1
 	ISQUAD = QINP( BUF(1), QTRANS(1), .FALSE., BUF(50) )
 	xa = (qtrans(1) - xcent) / scale
 	ya = (qtrans(2) - ycent) / scale
 	za =  qtrans(3) / scale
 	ra =  qtrans(4) / scale
 	write (output,803) xa,ya,za,ra, (qtrans(i),i=5,17)
  803	format(4f10.4,4x,3f6.3,/,10(1x,f10.4))
*
      ELSEIF (INTYPE.EQ.GPROP) THEN
	read (input,702,end=50) line
	do j = 132, 1, -1
	    if (line(j:j).ne.' '.and.line(j:j).ne.'	') l = j
	enddo
	if (line(l:l+2).eq.'FOG') then
	    write(output,1) line
	else if (line(l:l+8).EQ.'FRONTCLIP') then
	    read (line(l+10:132),*) zclip
	    zclip = zclip / TMAT(4,4)
	    write(output,'(''FRONTCLIP '',f7.3)') zclip
	else if (line(l:l+7).EQ.'BACKCLIP') then
	    read (line(10:132),*) zclip
	    zclip = zclip / TMAT(4,4)
	    write(output,'(''BACKCLIP '',f7.3)') zclip
	else if (line(l:l+7).eq.'ROTATION') then
	    read (line(l+9:132),*,err=771,end=771)
     &		((RAFTER(i,j),j=1,3),i=1,3)
     	    goto 772
  771	    read (input,*,err=48) ((RAFTER(i,j),j=1,3),i=1,3)
  772	    continue
	    WRITE (NOISE,775) ((RAFTER(I,J),J=1,3),I=1,3)
  775       FORMAT('Post-rotation matrix:  ',3(/,3F10.4))
 	    d = det(rafter)
	    IF (ABS(1.0-ABS(D)).GT.0.02) WRITE (NOISE,*)
     &      '>>> Warning: Post-rotation matrix has determinant',D
	    call qsetup
	    write(output,'(''DUMMY ROTATION'')')
	else if (line(l:l+10).eq.'TRANSLATION') then
	    read (input,*,err=48) (TAFTER(i),i=1,3)
	    write(output,'(''DUMMY TRANSLATION'')')
	else
	    write(output,1) line
	endif
	goto 7
   48	continue
   	write(NOISE,'(A,A)')
     &	    '>> Unrecognized or incomplete GPROP option ',LINE
c
      ELSEIF (INTYPE.EQ.INTERNAL) THEN
        CALL ASSERT(.FALSE.,'>>> Object type 4 not supported')
      ELSE
        CALL ASSERT(.FALSE.,'crash 50')
      ENDIF
      GO TO 7
*
*     here for end of objects
*
50    CONTINUE
      IF (ILEVEL.GT.0) THEN
	ILEVEL = ILEVEL - 1
	IF (VERBOSE) WRITE (NOISE,*) ' - closing indirect input file'
	CLOSE(INPUT)
	IF (ILEVEL.EQ.0) THEN
	  INPUT = STDIN
	ELSE
	  INPUT = INPUT - 1
	ENDIF
	GOTO 7
      ENDIF
*
      WRITE(NOISE,*)'-------------------------------'
      IF (NPLANES.NE.0) WRITE(NOISE,*) 'planes            =',NPLANES
      IF (NSPHERE.NE.0) WRITE(NOISE,*) 'spheres           =',NSPHERE
      IF (NCYLIND.NE.0) WRITE(NOISE,*) 'cylinders         =',NCYLIND
      IF (NTRIANG.NE.0) WRITE(NOISE,*) 'triangles         =',NTRIANG
      IF (NQUADS .NE.0) WRITE(NOISE,*) 'quadric surfaces  =',NQUADS
      IF (NTRANSP.NE.0) WRITE(NOISE,*) 'transparent objs  =',NTRANSP
      WRITE(NOISE,*)'-------------------------------'
      IF (NLABELS.NE.0) WRITE(NOISE,*) 'labels            =',NLABELS
      WRITE(NOISE,*)'-------------------------------'
*
      WRITE (NOISE,*) 'Compare these to the array dimensions in render:'
      IF (NPROPM.NE.0) WRITE(NOISE,*)  'special materials =',NPROPM,
     &                '   (check against MAXMAT)'
      WRITE(NOISE,*)  'total objects     =',N,
     &                '   (check against MAXOBJ)'
      WRITE (NOISE,*) 'details           =',NDET,
     &                '   (check against MAXDET)'
      WRITE (NOISE,*) 'shadow details    =',MDET,
     &                '   (check against MAXSDT)'
      WRITE(NOISE,*)'-------------------------------'
*
*
*     Sort objects, fill in "short lists" as indices into main list
*     (note that it would lend itself better to "parallel
*     processing" to form the short lists first and then
*
      WRITE (NOISE,*) 'True center of input coordinates (not used):'
	XA = (TRULIM(1,1) + TRULIM(1,2)) / 2.0
	YA = (TRULIM(2,1) + TRULIM(2,2)) / 2.0
	ZA = (TRULIM(3,1) + TRULIM(3,2)) / 2.0
      WRITE (NOISE,'(3F10.4)') XA, YA, ZA
*
      call exit(0)
      end

      SUBROUTINE ASSERT (LOGIC, DAMMIT)
      LOGICAL LOGIC
      CHARACTER*(*) DAMMIT
      INTEGER ASSOUT
      LOGICAL VERBOSE
      COMMON /ASSCOM/ ASSOUT, VERBOSE
      SAVE /ASSCOM/
      IF (LOGIC) RETURN
      WRITE (ASSOUT,*) 'ERROR >>>>>> ',DAMMIT
C     STOP 1234
      CALL EXIT(-1)
      END

      SUBROUTINE TRANSF (X,Y,Z)
*     Input transformation
      COMMON /MATRICES/ XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT,
     &                  TMAT, TINV, TINVT, SROT, SRTINV, SRTINVT
     &                 ,RAFTER, TAFTER
      REAL   XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT
*     Transformation matrix, inverse of transpose, and transposed inverse
      REAL   TMAT(4,4), TINV(4,4), TINVT(4,4)
*     Shortest rotation from light source to +z axis
      REAL   SROT(4,4), SRTINV(4,4), SRTINVT(4,4)
*     Post-hoc transformation on top of original TMAT
      REAL   RAFTER(4,4), TAFTER(3)
      REAL   X,Y,Z
      REAL   G(4),H(4)
      H(1) = X*TMAT(1,1) + Y*TMAT(2,1) + Z*TMAT(3,1) + TMAT(4,1)
      H(2) = X*TMAT(1,2) + Y*TMAT(2,2) + Z*TMAT(3,2) + TMAT(4,2)
      H(3) = X*TMAT(1,3) + Y*TMAT(2,3) + Z*TMAT(3,3) + TMAT(4,3)
      H(4) = X*TMAT(1,4) + Y*TMAT(2,4) + Z*TMAT(3,4) + TMAT(4,4)
*     Apply post-hoc rotation and translation also
      G(1) = RAFTER(1,1)*H(1) + RAFTER(1,2)*H(2) + RAFTER(1,3)*H(3)
     &     + TAFTER(1)
      G(2) = RAFTER(2,1)*H(1) + RAFTER(2,2)*H(2) + RAFTER(2,3)*H(3)
     &     + TAFTER(2)
      G(3) = RAFTER(3,1)*H(1) + RAFTER(3,2)*H(2) + RAFTER(3,3)*H(3)
     &     + TAFTER(3)
      CALL ASSERT (H(4).NE.0.,'infinite vector')
      X = G(1) / H(4)
      Y = G(2) / H(4)
      Z = G(3) / H(4)
      RETURN
      END

	SUBROUTINE CHKRGB( RED, GRN, BLU, MESSAGE )
	REAL RED, GRN, BLU
	CHARACTER*(*) MESSAGE
        CALL ASSERT (RED.GE.0., MESSAGE)
        CALL ASSERT (GRN.GE.0., MESSAGE)
        CALL ASSERT (BLU.GE.0., MESSAGE)
        CALL ASSERT (RED.LE.1., MESSAGE)
        CALL ASSERT (GRN.LE.1., MESSAGE)
        CALL ASSERT (BLU.LE.1., MESSAGE)
	RETURN
	END

	subroutine liblookup( name, fullname )
c
	character*(*) name
	character*132 fullname
	character*132  R3DLIB
c
	call getenv('R3D_LIB',R3DLIB)
c
	fullname = ' '
	len = len_trim(R3DLIB)
	if (len.eq.0) then
	    fullname = name
	    return
	else
	    fullname(1:len) = R3DLIB(1:len)
	    fullname(len+1:len+1) = '/'
	    j = len+2
	endif
c
	len = 0
  100	continue
	len = len + 1
	if (name(len:len).ne.' ') goto 100
	len = len - 1
c
	fullname(j:j+len-1) = name(1:len)
	len = j+len-1
c
	return
	end

        FUNCTION DET( A )
        REAL     DET, A(4,4)
        DET = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1)
     &      + A(2,1)*A(3,2)*A(1,3) - A(1,1)*A(2,3)*A(3,2)
     &      - A(3,3)*A(1,2)*A(2,1) - A(1,3)*A(2,2)*A(3,1)
        RETURN
        END


        SUBROUTINE BRAINFORT(PROG,N,INF,OUF,F)	!Stand strong!
Converts the Brain*uck in PROG into the equivalent furrytran source...
         CHARACTER*(*) PROG	!The Brain*uck source.
         INTEGER N		!A size for the STORE.
         INTEGER INF,OUF,F	!I/O unit numbers.
         INTEGER L		!A stepper.
         INTEGER LABEL,NLABEL,INDEEP,STACK(66)	!Labels cause difficulty.
         CHARACTER*1 C		!The operation of the moment.
         CHARACTER*36 SOURCE	!A scratchpad.
          WRITE (F,1) PROG,N	!The programme heading.
    1     FORMAT (6X,"PROGRAM BRAINFORT",/,	!Name it.
     1     "Code: ",A,/				!Show the provenance.
     2     6X,"CHARACTER*1 STORE(",I0,")",/	!Declare the working memory.
     3     6X,"INTEGER D",/			!The finger to the cell of the moment.
     4     6X,"STORE = CHAR(0)",/		!Clear to nulls, not spaces.
     5     6X,"D = 1",/)			!Start the data finger at the first cell.
          NLABEL = 0		!No labels seen.
          INDEEP = 0		!So, the stack is empty.
          LABEL = 0		!And the current label is absent.
          L = 1			!Start at the start.
Chug through the PROG.
          DO WHILE(L.LE.LEN(PROG))	!And step through to the end.
            C = PROG(L:L)		!The code of the moment.
            SELECT CASE(C)		!What to do?
             CASE(">")			!Move the data finger forwards one.
              WRITE (SOURCE,2) "D = D + ",RATTLE(">")	!But, catch multiple steps.
             CASE("<")			!Move the data finger back one.
              WRITE (SOURCE,2) "D = D - ",RATTLE("<")	!Rather than a sequence of one steps.
             CASE("+")			!Increment the fingered datum by one.
              WRITE (SOURCE,2) "STORE(D) = CHAR(ICHAR(STORE(D)) + ",	!Catching multiple increments.
     1         RATTLE("+"),")"						!And being careful over the placement of brackets.
             CASE("-")			!Decrement the fingered datum by one.
              WRITE (SOURCE,2) "STORE(D) = CHAR(ICHAR(STORE(D)) - ",	!Catching multiple decrements.
     1         RATTLE("-"),")"						!And closing brackets.
             CASE(".")			!Write a character.
              WRITE (SOURCE,2) "WRITE (",OUF,",'(A1,$)') STORE(D)"	!Using the given output unit.
             CASE(",")			!Read a charactger.
              WRITE (SOURCE,2) "READ (",INF,",'(A1)') STORE(D)"		!And the input unit.
             CASE("[")			!A label!
              NLABEL = NLABEL + 1		!Labels come in pairs due to [...]
              LABEL = 2*NLABEL - 1		!So this belongs to the [.
              INDEEP = INDEEP + 1		!I need to remember when later the ] is encountered.
              STACK(INDEEP) = LABEL + 1		!This will be the other label.
              WRITE (SOURCE,2) "IF (ICHAR(STORE(D)).EQ.0) GO TO ",	!So, go thee, therefore.
     1         STACK(INDEEP)			!Its placement will come, all going well.
             CASE("]")			!The end of a [...] pair.
              LABEL = STACK(INDEEP)		!This was the value of the label to be, now to be placed.
              WRITE (SOURCE,2) "IF (ICHAR(STORE(D)).NE.0) GO TO ",	!The conditional part
     1         LABEL - 1			!The branch back destination is known by construction.
              INDEEP = INDEEP - 1		!And we're out of the [...] sequence's consequences.
             CASE DEFAULT		!All others are ignored.
              SOURCE = "CONTINUE"		!So, just carry on.
            END SELECT			!Enough of all that.
    2       FORMAT (A,I0,A)	!Text, an integer, text.
Cast forth the statement.
            IF (LABEL.LE.0) THEN	!Is a label waiting?
              WRITE (F,3) SOURCE		!No. Just roll the source.
    3         FORMAT (<6 + 2*MIN(12,INDEEP)>X,A)!With indentation.
             ELSE			!But if there is a label,
              WRITE (F,4) LABEL,SOURCE		!Slightly more complicated.
    4         FORMAT (I5,<1 + 2*MIN(12,INDEEP)>X,A)	!I align my labels rightwards...
              LABEL = 0				!It is used.
            END IF			!So much for that statement.
            L = L + 1		!Advance to the next command.
          END DO		!And perhaps we're finished.

Closedown.
          WRITE (F,100)		!No more source.
  100     FORMAT (6X,"END")	!So, this is the end.
         CONTAINS	!A function with odd effects.
          INTEGER FUNCTION RATTLE(C)	!Advances thrugh multiple C, counting them.
           CHARACTER*1 C	!The symbol.
            RATTLE = 1		!We have one to start with.
    1       IF (L.LT.LEN(PROG)) THEN	!Further text to look at?
              IF (PROG(L + 1:L + 1).EQ.C) THEN	!Yes. The same again?
              	L = L + 1		!Yes. Advance the finger to it.
                RATTLE = RATTLE + 1	!Count another.
                GO TO 1			!And try again.
              END IF			!Rather than just one at a time.
            END IF			!Curse the double evaluation of WHILE(L < LEN(PROG) & ...)
          END FUNCTION RATTLE	!Computers excel at counting.
        END SUBROUTINE BRAINFORT!Their only need be direction as to what to count...
      END MODULE BRAIN	!Simple in itself.

      PROGRAM POKE	!A tester.
      USE BRAIN		!In a rather bad way.
      CHARACTER*1 STORE(30000)	!Probably rather more than is needed.
      CHARACTER*(*) HELLOWORLD	!Believe it or not...
      PARAMETER (HELLOWORLD = "++++++++[>++++[>++>+++>+++>+<<<<-]"
     1 //" >+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------"
     2 //".--------.>>+.>++.")
      INTEGER F
      KBD = 5		!Standard input.
      MSG = 6		!Standard output.
      F = 10

      STORE = CHAR(0)	!Scrub.

c      CALL RUN(HELLOWORLD,STORE)	!Have a go.

      OPEN (F,FILE="BrainFort.for",STATUS="REPLACE",ACTION="WRITE")
      CALL BRAINFORT(HELLOWORLD,30000,KBD,MSG,F)
      END	!Enough.


!-----------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in    !
!  continuous development by various groups and is based on information !
!  from these groups: Federal Government employees, contractors working !
!  within a United States Government contract, and non-Federal sources  !
!  including research institutions.  These groups give the Government   !
!  permission to use, prepare derivative works of, and distribute copies!
!  of their work in the CMAQ system to the public and to permit others  !
!  to do so.  The United States Environmental Protection Agency         !
!  therefore grants similar permission to use the CMAQ system software, !
!  but users are requested to provide copies of derivative works or     !
!  products designed to operate in the CMAQ system to the United States !
!  Government without restrictions as to use by others.  Software       !
!  that is used with the CMAQ system but distributed under the GNU      !
!  General Public License or the GNU Lesser General Public License is   !
!  subject to their copyright restrictions.                             !
!-----------------------------------------------------------------------!

C RCS file, release, date & time of last delta, author, state, [and locker]
C $Header: /project/yoj/arc/JPROC/src/driver/jproc_table/o3scal.f,v 1.5 2011/10/29 01:03:53 sjr Exp $

C what(1) key, module and SID; SCCS file; date and time of last delta:
C @(#)o3scal.F	1.1 /project/mod3/JPROC/src/driver/jproc_table/SCCS/s.o3scal.F 23 May 1997 12:44:20

C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
       SUBROUTINE O3SCAL ( O3, HO3, XLAT, DOBNEW )

C*********************************************************************
C
C  adjustment of O3 profiles to a user-selected dobson value.
C   select value of DOBNEW in main program
C   if don't want to use, don't call this subroutine
C
C*********************************************************************

      IMPLICIT NONE

      INCLUDE 'JVALPARMS.EXT'    ! jproc parameters

C...........ARGUMENTS and their descriptions

      REAL         O3( MXLEV )        ! ozone profile
      REAL         HO3                ! ozone scale height
      REAL         XLAT               ! latitudinal band
      REAL         DOBNEW             ! new dobson unit

C...........LOCAL VARIABLES and their descriptions:

      LOGICAL, SAVE :: FIRSTTIME = .TRUE.

      INTEGER      I                  ! level index

      REAL         DOBSREF            ! reference dobson unit
      REAL         SCALE_FACTOR

C*********************************************************************
C     begin body of subroutine O3SCAL2

      IF ( FIRSTTIME ) THEN
        FIRSTTIME = .FALSE.
        WRITE ( 6, 2001 )
      END IF

C...convert O3 value into DU

      DOBSREF = O3( MXLEV ) * 1.0E5 * HO3
      DO I = 1, MXLEV
        DOBSREF = DOBSREF + O3( I ) * 1.0E5
      END DO
      DOBSREF = DOBSREF / 2.687E16

C...apply scale factor to O3 profile if a non-zero TOC value provided

      IF ( DOBNEW .GT. 0.0 ) THEN
        SCALE_FACTOR = DOBNEW / DOBSREF
        WRITE( 6, 2003 ) XLAT, DOBSREF, DOBNEW, SCALE_FACTOR
        DO I = 1, MXLEV
          O3( I ) = O3( I ) * SCALE_FACTOR
        END DO
      ELSE
        WRITE( 6, 2005 ) XLAT, DOBSREF
      END IF

C...formats

2001  FORMAT( 1X, 'Rescaling O3 profile based on TOC data' )
2003  FORMAT( 7X, 'Latitude:', 1X, F5.1, ', oldDOBS=', F9.4, ', newDOBS=',
     &        F9.4, ', scale factor=', F7.4 )
2005  FORMAT( 7X, 'Latitude:', 1X, F5.1, ', DOBS=', F9.4, ', not rescaled' )

      RETURN
      END