subroutine putprofad,1
      use mod4dv, only : mvar, maxxy
      implicit none
*
* Author: Simon Pellerin *ARMA/SMC Nov. 2001
* Purpose: Write adjoint profile in prof file for adjoint model integration
*
* Revision:
*       S. Pellerin *ARMA/SMC Feb. 2002
*            . Fix for automatic arrays dimensioned from common block
*              (causing problems with PGI compilation)
*            . Fix to Model tag writing
*       S. Pellerin, ARMA, August 2008
*             - Added calls to 'tmg_*' subroutines
*       C. Charette, ARMA 2007
*             - Added handling of O3, CH4 and N2O
*
#include "comdim.cdk"
#include "comlun.cdk"
#include "comdimo.cdk"
#include "commvo.cdk"
#include "comcva.cdk"
#include "comvfiles.cdk"
#include "comchem.cdk"
c
c     Local variables
c
      integer ihdlout, prof_wrrec, imvar, ix, iy, jx, jy
      integer iobs, istat, jk, jobs,i,j, jlat, jbit,ipes
      INTEGER ITR, ITRLEV, JTR
      character (len=128) :: clprof
      character (len=2) :: cljx, cljy
      real*8, allocatable, dimension(:,:) :: dlbuff
      real*8, allocatable, dimension(:) :: dlbuff2d
      integer, allocatable, dimension(:) :: ibuff2d
c
      include 'prof_f.h'
c
      allocate(dlbuff(nflev,nobtot))
      allocate(dlbuff2d(nobtot))
      allocate(ibuff2d(nobtot))
      ix = 0
      iy = 0
      call mvbits(maxxy,16,16,ix,0)
      call mvbits(maxxy,0,16,iy,0)
c
      imvar = mvar
      imvar = ibset(imvar,v2d_mtag)
      write(nulout,*) 'Entering PUTPROFAD for simulation ',nsim3d
      call vflush(nulout)
c
      do jy = 0, iy
        do jx = 0, ix
          ipes = 0
          ipes = ishft(jx,16)
          call mvbits(jy,0,16,ipes,0)
c
          write(cljx,'(i2.2)') jx
          write(cljy,'(i2.2)') jy
          clprof = trim(CEXC4DV) // '/dwya_'//cljx//'_'//cljy//'.prof'
c
          IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')

          istat = 0
          do jbit = 0,31
            if(btest(imvar,jbit)) call putfld(jbit,istat,ipes)
          enddo
c
          if(istat == 0) then
            ISTAT = PROF_PVAR(IHDLOUT,nsim3d,PRM_EVNT) + istat
            call tmg_start(81,'PROF_R+W')
            ISTAT = prof_wrrec(IHDLOUT) + istat
            ISTAT = PROF_CLOSE(IHDLOUT)
            call tmg_stop(81)
c
          else
            write(nulout,*)
     &           'PUTPROFAD - ERROR : Problems pushing fields in prof ',
     &           'data base'
            ISTAT = PROF_PVAR(IHDLOUT,evn_ferr,PRM_EVNT)

            call tmg_start(81,'PROF_R+W')
            ISTAT = PROF_CLOSE(IHDLOUT)
            call tmg_stop(81)

            clprof = trim(CEXC4DV) // '/evnt.prof'
            WRITE(NULOUT,*)'PUTPROFAD - SENDING EVN_FERR SIGNAL :'
     &           ,EVN_FERR
            IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
            ISTAT = PROF_PVAR(IHDLOUT,EVN_FERR,PRM_EVNT)
            call tmg_start(81,'PROF_R+W')
            istat = prof_wrrec(ihdlout)
            ISTAT = PROF_CLOSE(IHDLOUT)
            call tmg_stop(81)

            call abort3d(nulout,'PUTPROFAD')
          endif
        enddo
      enddo
c
      clprof = trim(CEXC4DV) // '/evnt.prof'
      WRITE(NULOUT,*)'PUTPROFAD - SENDING EVN_ADJM SIGNAL :'
     &     ,EVN_ADJM
      IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
      ISTAT = PROF_PVAR(IHDLOUT,EVN_ADJM,PRM_EVNT)
      call tmg_start(81,'PROF_R+W')
      istat = prof_wrrec(ihdlout)
      ISTAT = PROF_CLOSE(IHDLOUT)
      call tmg_stop(81)
c
      deallocate(dlbuff)
      deallocate(dlbuff2d)
      deallocate(ibuff2d)

      write(nulout,*) 'Leaving PUTPROFAD'
      call vflush(nulout)

      contains

      subroutine putfld(kbit,kstat,kpes) 1
c
      integer, intent(in) :: kbit, kpes
      integer, intent(inout) :: kstat
      integer :: jbuff
c
      jbuff = 0
      select case(kbit)
      case(V3D_UTRU)
        do jobs = 1, nobtot
          if(npexy(jobs) == kpes) then
            jbuff = jbuff + 1
            do jk = 1, nflev
              dlbuff(jk,jbuff) = gomu(jk,jobs)
            end do
          endif
        end do
        kstat = PROF_PVAR(IHDLOUT,DLbuff(:,1:jbuff),V3D_UTRU) + kstat
      case(V3D_VTRU)
        do jobs = 1, nobtot
          if(npexy(jobs) == kpes) then
            jbuff = jbuff + 1
            do jk = 1, nflev
              dlbuff(jk,jbuff) = gomv(jk,jobs)
            end do
          endif
        end do
        KSTAT = PROF_PVAR(IHDLOUT,DLBUFF(:,1:JBUFF),V3D_VTRU) + kstat
      case(V3D_TEMP)
        do jobs = 1, nobtot
          if(npexy(jobs) == kpes) then
            jbuff = jbuff + 1
            do jk = 1, nflev
              dlbuff(jk,jbuff) = gomt(jk,jobs)
            end do
          endif
        end do
        KSTAT = PROF_PVAR(IHDLOUT,DLBUFF(:,1:JBUFF),V3D_TEMP) + kstat
      case(V3D_SPHU)
        do jobs = 1, nobtot
          if(npexy(jobs) == kpes) then
            jbuff = jbuff + 1
            do jk = 1, nflev
              dlbuff(jk,jbuff) = gomq(jk,jobs)
            end do
          endif
        end do
        KSTAT = PROF_PVAR(IHDLOUT,DLBUFF(:,1:JBUFF),V3D_SPHU) + kstat
*
*       TRACERS
*
      case(V3D_O3)

        IF(NOCMT .GT. 0) THEN 
        DO JTR = 1,NOCMT
          IF(CMVOCMT(JTR) .EQ. 'O3') THEN
            ITR = JTR
            do jobs = 1, nobtot
              if(npexy(jobs) == kpes) then
                jbuff = jbuff + 1
                DO JK = 1, NFLEV
                  ITRLEV = (ITR-1)*NFLEV + JK
                  dlbuff(jk,jbuff) = gomtr(itrlev,jobs)
                END DO
              endif
            END DO
          ENDIF
        END DO
        KSTAT = PROF_PVAR(IHDLOUT,DLBUFF(:,1:JBUFF),V3D_O3) +
     &           kstat
        ENDIF

      case(V3D_CH4)

        IF(NOCMT .GT. 0) THEN
        DO JTR = 1,NOCMT
          IF(CMVOCMT(JTR) .EQ. 'CH4') THEN
            ITR = JTR
            do jobs = 1, nobtot
              if(npexy(jobs) == kpes) then
                jbuff = jbuff + 1
                DO JK = 1, NFLEV
                  ITRLEV = (ITR-1)*NFLEV + JK
                  dlbuff(jk,jbuff) = gomtr(itrlev,jobs)
                END DO
              endif
            END DO
          ENDIF
        END DO
        KSTAT = PROF_PVAR(IHDLOUT,DLBUFF(:,1:JBUFF),V3D_CH4) +
     &           kstat
        ENDIF

      case(V3D_N2O)

        IF(NOCMT .GT. 0) THEN
        DO JTR = 1,NOCMT
          IF(CMVOCMT(JTR) .EQ. 'N2O') THEN
            ITR = JTR
            do jobs = 1, nobtot
              if(npexy(jobs) == kpes) then
                jbuff = jbuff + 1
                DO JK = 1, NFLEV
                  ITRLEV = (ITR-1)*NFLEV + JK
                  dlbuff(jk,jbuff) = gomtr(itrlev,jobs)
                END DO
              endif
            END DO
          ENDIF
        END DO
        KSTAT = PROF_PVAR(IHDLOUT,DLBUFF(:,1:JBUFF),V3D_N2O) +
     &           kstat
        ENDIF

      case(V2D_PSUR)

        do jobs = 1, nobtot
          if(npexy(jobs) == kpes) then
            jbuff = jbuff + 1
            dlbuff2d(jbuff) = gomps(1,jobs)
          endif
        end do
        KSTAT = PROF_PVAR(IHDLOUT,DLbuff2D(1:jbuff),V2D_PSUR) + kstat
      case(V2D_TGRN)
        do jobs = 1, nobtot
          if(npexy(jobs) == kpes) then
            jbuff = jbuff + 1
            dlbuff2d(jbuff) = gomtgr(1,jobs)
          endif
        enddo
        KSTAT = PROF_PVAR(IHDLOUT,DLbuff2D(1:jbuff),V2D_TGRN) + kstat
      case(V2D_MTAG)
        do jobs = 1, nobtot
          if(npexy(jobs) == kpes) then
            jbuff = jbuff + 1
            ibuff2d(jbuff) = mtag(jobs)
          endif
        end do
        KSTAT = PROF_PVAR(IHDLOUT,ibuff2D(1:jbuff),V2D_MTAG) + kstat
      end select

      end subroutine putfld
      end subroutine putprofad