C
      subroutine flp2to3b(it1,it2,it3,id,jd,npoints,ntets)
C
C ######################################################################
C
C      PURPOSE -
C
C         This routine takes two tets into three tets:
C            (i1,i2,i3,i4) - (j1,j2,j3,xx)
C            (i1,i3,i2,i5) - (k1,k2,k3,xx)
C            -----------------------------------------
C            (i1,i2,i5,i4) - { (2,it2),(1,it3),j3,k2 }
C            (i2,i3,i5,i4) - { (2,it3),(1,it1),j1,k1 }
C            (i3,i1,i5,i4) - { (2,it1),(1,it2),j2,k3 }
C
C      INPUT ARGUMENTS -
C
C         it1   - the first tet
C         it2   - the second tet
C         id    - the 'itet' values of the three new tets
C         jd    - the 'jtet' values of the three new tets
C
C      OUTPUT ARGUMENTS -
C
C         None
C
C     CHANGE HISTORY -
C
C        $Log: flp2to3b.f,v $
C        Revision 2.00  2007/11/05 19:45:55  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.1   08 Jan 2002 08:37:22   dcg
CPVCS    remove waring message about increasing array sizes
CPVCS
CPVCS       Rev 1.0   07 Feb 2000 17:44:24   dcg
CPVCS    Initial revision.
CPVCS
CPVCS       Rev 1.9   Mon Feb 01 13:33:04 1999   dcg
CPVCS    update itettyp for newly created element
CPVCS
CPVCS       Rev 1.8   Fri Sep 26 13:54:38 1997   dcg
CPVCS    refresh pointers after hmemadjb call
CPVCS
CPVCS       Rev 1.7   Mon Apr 14 16:48:46 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.6   08/10/95 16:20:24   dcg
CPVCS    replace print * with writloga statements
CPVCS
CPVCS       Rev 1.5   06/20/95 15:44:00   dcg
CPVCS    remove character literals from arguments list to hgetprt
CPVCS
CPVCS       Rev 1.4   05/01/95 08:36:02   het
CPVCS    Modifiy all the storage block calles for long names
CPVCS
CPVCS       Rev 1.3   12/02/94 15:05:34   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:47:32   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:52:00   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:13:14   pvcs
CPVCS    Original version.
C
C ######################################################################
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"
C
C ######################################################################
C  arguments (it1,it2,it3,id,jd,npoints,ntets)
      integer it2,it3,it1,npoints,ntets,id(12),jd(12)

C  variables
      integer ierror,icmotype,leni,jtemp
      integer i,j,k,i1,i2,i3,i4,icscode,it1sum,it2sum,ierrfls,it3sum

      real*8 crosx1,crosy1,crosz1,volume,volit1,volit2,volit3
C
C ######################################################################
C
C     DEFINE THE STATEMENT FUNCTIONS NEEDED TO CALCULATE TET VOLUMES.
C
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
      volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
     *                    (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
     *                    (zic(i4)-zic(i1))*crosz1(i1,i2,i3)
C
      character*4 if1,if2,if3,if4
      character*8 cpart

C ######################################################################
C
C
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      cpart='part'
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,leni,icmotype,ierror)
      call cmo_get_info('imt1',cmo,ipimt1,leni,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,leni,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,leni,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,leni,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,leni,icmotype,ierror)
      call cmo_get_info('itettyp',cmo,ipitettyp,leni,icmotype,ierror)
      call cmo_get_info('itet',cmo,ipitet,leni,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,leni,icmotype,ierror)
C
      endif
C
C     ******************************************************************
C     MAKE THE THREE NEW TETRAHEDRON ASSIGNMENTS
C
      call mmgetlen(ipitet,leni,icscode)
      if(4*(ntets+1).ge.leni) then
c       write(logmess,'(a,a)') 'Trying to increment nodnbrp arrays in ',
c    *             'flp2to3b'
c        call writloga('default',0,logmess,0,ierror)
         call hmemadjb('nodnbrp ',1)

         call cmo_get_info('imt1',cmo,ipimt1,leni,icmotype,ierror)
         call cmo_get_info('xic',cmo,ipxic,leni,icmotype,ierror)
         call cmo_get_info('yic',cmo,ipyic,leni,icmotype,ierror)
         call cmo_get_info('zic',cmo,ipzic,leni,icmotype,ierror)
         call cmo_get_info('itetclr',cmo,ipitetclr,leni,icmotype,
     *                     ierror)
         call cmo_get_info('itettyp',cmo,ipitettyp,leni,icmotype,
     *                     ierror)
         call cmo_get_info('itet',cmo,ipitet,leni,icmotype,ierror)
         call cmo_get_info('jtet',cmo,ipjtet,leni,icmotype,ierror)

      endif
      ntets=ntets+1
      if(icmoset.eq.1) then
         call cmo_set_info('nelements',cmo,ntets,1,1,ierror)
      endif
      it3=ntets
C
      itet(1,it1)=id(1)
      jtet(1,it1)=jd(1)
      itet(2,it1)=id(2)
      jtet(2,it1)=jd(2)
      itet(3,it1)=id(3)
      jtet(3,it1)=jd(3)
      itet(4,it1)=id(4)
      jtet(4,it1)=jd(4)
C
      itet(1,it2)=id(5)
      jtet(1,it2)=jd(5)
      itet(2,it2)=id(6)
      jtet(2,it2)=jd(6)
      itet(3,it2)=id(7)
      jtet(3,it2)=jd(7)
      itet(4,it2)=id(8)
      jtet(4,it2)=jd(8)
C
      itetclr(it3)=itetclr(it1)
      itettyp(it3)=itettyp(it1)
      itet(1,it3)=id(9)
      jtet(1,it3)=jd(9)
      itet(2,it3)=id(10)
      jtet(2,it3)=jd(10)
      itet(3,it3)=id(11)
      jtet(3,it3)=jd(11)
      itet(4,it3)=id(12)
      jtet(4,it3)=jd(12)
C
C     .................................
C     ******************************************************************
C     MAKE THE JTET ARRAY CONSISTENT
C
      if(jtet(3,it2).lt.mbndry) then
         jtet1(jtet(3,it2))=4*(it2-1)+3
      elseif(jtet(3,it2).gt.mbndry) then
         jtemp=jtet(3,it2)-mbndry
         jtet1(jtemp)=4*(it2-1)+3+mbndry
      endif
      if(jtet(3,it3).lt.mbndry) then
         jtet1(jtet(3,it3))=4*(it3-1)+3
      elseif(jtet(3,it3).gt.mbndry) then
         jtemp=jtet(3,it3)-mbndry
         jtet1(jtemp)=4*(it3-1)+3+mbndry
      endif
      if(jtet(3,it1).lt.mbndry) then
         jtet1(jtet(3,it1))=4*(it1-1)+3
      elseif(jtet(3,it1).gt.mbndry) then
         jtemp=jtet(3,it1)-mbndry
         jtet1(jtemp)=4*(it1-1)+3+mbndry
      endif
      if(jtet(4,it2).lt.mbndry) then
         jtet1(jtet(4,it2))=4*(it2-1)+4
      elseif(jtet(4,it2).gt.mbndry) then
         jtemp=jtet(4,it2)-mbndry
         jtet1(jtemp)=4*(it2-1)+4+mbndry
      endif
      if(jtet(4,it1).lt.mbndry) then
         jtet1(jtet(4,it1))=4*(it1-1)+4
      elseif(jtet(4,it1).gt.mbndry) then
         jtemp=jtet(4,it1)-mbndry
         jtet1(jtemp)=4*(it1-1)+4+mbndry
      endif
      if(jtet(4,it3).lt.mbndry) then
         jtet1(jtet(4,it3))=4*(it3-1)+4
      elseif(jtet(4,it3).gt.mbndry) then
         jtemp=jtet(4,it3)-mbndry
         jtet1(jtemp)=4*(it3-1)+4+mbndry
      endif
C
C     ******************************************************************
C
      if(idebug.gt.1) then
        it1sum=itet(1,it1)+itet(2,it1)+itet(3,it1)+itet(4,it1)
        volit1=volume(itet(1,it1),itet(2,it1),itet(3,it1),itet(4,it1))
        it2sum=itet(1,it2)+itet(2,it2)+itet(3,it2)+itet(4,it2)
        volit2=volume(itet(1,it2),itet(2,it2),itet(3,it2),itet(4,it2))
        it3sum=itet(1,it3)+itet(2,it3)+itet(3,it3)+itet(4,it3)
        volit3=volume(itet(1,it3),itet(2,it3),itet(3,it3),itet(4,it3))
        i1=itet(1,it1)
        i2=itet(2,it1)
        i3=itet(3,it1)
        i4=itet(4,it1)
        if1=' '
        if(jtet(1,it1).ge.mbndry) if1='*'
        if2=' '
        if(jtet(2,it1).ge.mbndry) if2='*'
        if3=' '
        if(jtet(3,it1).ge.mbndry) if3='*'
        if4=' '
        if(jtet(4,it1).ge.mbndry) if4='*'
        write(logdan,9000) '        ',it1,'new=',
     *                     i1,if1,i2,if2,i3,if3,i4,if4,
     *                     it1sum,volit1
        call writloga('bat',0,logdan,0,ierror)
        i1=itet(1,it2)
        i2=itet(2,it2)
        i3=itet(3,it2)
        i4=itet(4,it2)
        if1=' '
        if(jtet(1,it2).ge.mbndry) if1='*'
        if2=' '
        if(jtet(2,it2).ge.mbndry) if2='*'
        if3=' '
        if(jtet(3,it2).ge.mbndry) if3='*'
        if4=' '
        if(jtet(4,it2).ge.mbndry) if4='*'
        write(logdan,9010) '        ',it2,'new=',
     *                     i1,if1,i2,if2,i3,if3,i4,if4,
     *                     it2sum,volit2
        call writloga('bat',0,logdan,0,ierror)
        i1=itet(1,it3)
        i2=itet(2,it3)
        i3=itet(3,it3)
        i4=itet(4,it3)
        if1=' '
        if(jtet(1,it3).ge.mbndry) if1='*'
        if2=' '
        if(jtet(2,it3).ge.mbndry) if2='*'
        if3=' '
        if(jtet(3,it3).ge.mbndry) if3='*'
        if4=' '
        if(jtet(4,it3).ge.mbndry) if4='*'
        write(logdan,9020) '        ',it3,'new=',
     *                     i1,if1,i2,if2,i3,if3,i4,if4,
     *                     it3sum,volit3
        call writloga('bat',0,logdan,0,ierror)
 9000   format(a8,' it1=',i8,1x,a4,4(i7,a1),i8,1x,1pe10.3)
 9010   format(a8,' it2=',i8,1x,a4,4(i7,a1),i8,1x,1pe10.3)
 9020   format(a8,' it3=',i8,1x,a4,4(i7,a1),i8,1x,1pe10.3)
        call writfls('bat',ierrfls)
C*****  call tettestd
      endif
C
      goto 9999
 9999 continue
      return
      end


ACCEPTABLE LEFT PRIMERS
                                  1-based     #               self  self  qual-
   # sequence                       start ln  N   GC%     Tm   any   end   lity
   0 AACCTGGCTACAGTTCCCTC              72 20  0 55.00 58.255  3.00  0.00  1.745
   1 AAACCTGGCTACAGTTCCCTC             71 21  0 52.38 59.630  3.00  0.00  1.370
   2 GAAACCTGGCTACAGTTCCCTC            70 22  0 54.55 61.364  3.00  0.00  3.364
   3 AGAAACCTGGCTACAGTTCCCTC           69 23  0 52.17 62.164  3.00  0.00  5.164
   4 AAACCTGGCTACAGTTCCCT              71 20  0 50.00 57.789  3.00  1.00  2.211
   5 GAAACCTGGCTACAGTTCCCT             70 21  0 52.38 59.630  3.00  1.00  1.370
   6 AGAAACCTGGCTACAGTTCCCT            69 22  0 50.00 60.528  3.00  2.00  2.528
   7 GAAACCTGGCTACAGTTCCC              70 20  0 55.00 58.646  3.00  3.00  1.354
   8 AGAAACCTGGCTACAGTTCCC             69 21  0 52.38 59.630  3.00  3.00  1.370
   9 CAGAAACCTGGCTACAGTTCCC            68 22  0 54.55 62.245  3.00  3.00  4.245
  10 CAGAAACCTGGCTACAGTTCC             68 21  0 52.38 58.851  3.00  2.00  2.149
  11 TCAGAAACCTGGCTACAGTTCC            67 22  0 50.00 60.661  3.00  2.00  2.661
  12 CTCAGAAACCTGGCTACAGTTCC           66 23  0 52.17 61.514  3.00  2.00  4.514
  13 TCAGAAACCTGGCTACAGTTC             67 21  0 47.62 57.065  3.00  2.00  3.935
  14 CTCAGAAACCTGGCTACAGTTC            66 22  0 50.00 58.135  3.00  2.00  3.865
  15 CCTCAGAAACCTGGCTACAGTTC           65 23  0 52.17 61.514  3.00  2.00  4.514
  16 CCTCAGAAACCTGGCTACAGTT            65 22  0 50.00 59.810  3.00  2.00  2.190
  17 CCTCAGAAACCTGGCTACAGT             65 21  0 52.38 58.468  3.00  3.00  2.532
  18 GCCTCAGAAACCTGGCTACAGT            64 22  0 54.55 62.045  3.00  3.00  4.045
  19 CCTCAGAAACCTGGCTACAG              65 20  0 55.00 57.547  3.00  3.00  2.453
  20 GCCTCAGAAACCTGGCTACAG             64 21  0 57.14 61.316  3.00  3.00  2.316
  21 GCCTCAGAAACCTGGCTACA              64 20  0 55.00 60.397  3.00  1.00  0.397
  22 GCCTCAGAAACCTGGCTAC               64 19  0 57.89 57.465  3.00  3.00  3.535
  23 TGCCTCAGAAACCTGGCTAC              63 20  0 55.00 60.397  3.00  3.00  0.397
  24 GTGCCTCAGAAACCTGGCTAC             62 21  0 57.14 61.195  3.00  3.00  2.195
  25 TGCCTCAGAAACCTGGCTA               63 19  0 52.63 59.531  3.00  2.00  1.469
  26 GTGCCTCAGAAACCTGGCTA              62 20  0 55.00 60.397  3.00  2.00  0.397
  27 TGCCTCAGAAACCTGGCT                63 18  0 55.56 59.499  3.00  3.00  2.501
  28 GTGCCTCAGAAACCTGGCT               62 19  0 57.89 60.402  3.00  3.00  1.402
  29 GTGCCTCAGAAACCTGGC                62 18  0 61.11 59.345  3.00  2.00  2.655
  30 TGTGCCTCAGAAACCTGGC               61 19  0 57.89 62.397  3.00  2.00  3.397
  31 TGTGCCTCAGAAACCTGG                61 18  0 55.56 58.249  3.00  3.00  3.751
  32 CTGTGCCTCAGAAACCTGG               60 19  0 57.89 59.399  5.00  3.00  1.601
  33 CCTGTGCCTCAGAAACCTG               59 19  0 57.89 59.399  5.00  2.00  1.601
  34 CCCTGTGCCTCAGAAACCT               58 19  0 57.89 60.245  5.00  0.00  1.245
  35 TCCCTGTGCCTCAGAAACCT              57 20  0 55.00 62.145  5.00  0.00  2.145
  36 GTCCCTGTGCCTCAGAAACCT             56 21  0 57.14 62.881  5.00  0.00  3.881
  37 CCCTGTGCCTCAGAAACC                58 18  0 61.11 59.180  5.00  1.00  2.820
  38 TCCCTGTGCCTCAGAAACC               57 19  0 57.89 61.213  5.00  1.00  2.213
  39 GTCCCTGTGCCTCAGAAACC              56 20  0 60.00 62.024  5.00  3.00  2.024
  40 TCCCTGTGCCTCAGAAAC                57 18  0 55.56 57.158  5.00  3.00  4.842
  41 GTCCCTGTGCCTCAGAAAC               56 19  0 57.89 58.201  5.00  5.00  2.799
  42 TGTCCCTGTGCCTCAGAAAC              55 20  0 55.00 61.259  5.00  5.00  1.259
  43 CTGTCCCTGTGCCTCAGAAAC             54 21  0 57.14 62.180  5.00  5.00  3.180
  44 GTCCCTGTGCCTCAGAAA                56 18  0 55.56 57.158  5.00  3.00  4.842
  45 TGTCCCTGTGCCTCAGAAA               55 19  0 52.63 60.385  5.00  3.00  1.385
  46 CTGTCCCTGTGCCTCAGAAA              54 20  0 55.00 61.390  5.00  3.00  1.390
  47 TGTCCCTGTGCCTCAGAA                55 18  0 55.56 58.812  5.00  1.00  3.188
  48 CTGTCCCTGTGCCTCAGAA               54 19  0 57.89 59.963  5.00  1.00  1.037
  49 CTGTCCCTGTGCCTCAGA                54 18  0 61.11 58.348  5.00  3.00  3.652
  50 CCTGTCCCTGTGCCTCAGA               53 19  0 63.16 62.470  5.00  3.00  3.470
  51 CCTGTCCCTGTGCCTCAG                53 18  0 66.67 60.405  5.00  5.00  2.405
  52 TCCTGTCCCTGTGCCTCAG               52 19  0 63.16 62.470  5.00  5.00  3.470
  53 TCCTGTCCCTGTGCCTCA                52 18  0 61.11 61.468  3.00  3.00  3.468
  54 TTCCTGTCCCTGTGCCTCA               51 19  0 57.89 62.869  3.00  3.00  3.869
  55 ATTCCTGTCCCTGTGCCTCA              50 20  0 55.00 62.996  3.00  3.00  2.996
  56 TATTCCTGTCCCTGTGCCTCA             49 21  0 52.38 62.891  3.00  3.00  3.891
  57 TTCCTGTCCCTGTGCCTC                51 18  0 61.11 59.749  2.00  1.00  2.251
  58 ATTCCTGTCCCTGTGCCTC               50 19  0 57.89 60.064  2.00  1.00  1.064
  59 TATTCCTGTCCCTGTGCCTC              49 20  0 55.00 60.073  2.00  1.00  0.073
  60 ATATTCCTGTCCCTGTGCCTC             48 21  0 52.38 60.342  4.00  1.00  1.342
  61 AATATTCCTGTCCCTGTGCCTC            47 22  0 50.00 61.574  6.00  1.00  3.574
  62 TAATATTCCTGTCCCTGTGCCTC           46 23  0 47.83 61.529  6.00  1.00  4.529
  63 TTAATATTCCTGTCCCTGTGCCTC          45 24  0 45.83 62.607  6.00  1.00  6.607
  64 ATTAATATTCCTGTCCCTGTGCCTC         44 25  0 44.00 62.718  6.00  1.00  7.718
  65 TATTAATATTCCTGTCCCTGTGCCTC        43 26  0 42.31 62.643  8.00  1.00  8.643
  66 ATATTAATATTCCTGTCCCTGTGCCTC       42 27  0 40.74 62.745 10.00  1.00  9.745
  67 ATTCCTGTCCCTGTGCCT                50 18  0 55.56 57.991  2.00  0.00  4.009
  68 TATTCCTGTCCCTGTGCCT               49 19  0 52.63 58.086  2.00  0.00  2.914
  69 ATATTCCTGTCCCTGTGCCT              48 20  0 50.00 58.473  4.00  0.00  1.527
  70 AATATTCCTGTCCCTGTGCCT             47 21  0 47.62 59.841  6.00  0.00  1.159
  71 TAATATTCCTGTCCCTGTGCCT            46 22  0 45.45 59.856  6.00  0.00  2.144
  72 TTAATATTCCTGTCCCTGTGCCT           45 23  0 43.48 61.044  6.00  0.00  4.044
  73 ATTAATATTCCTGTCCCTGTGCCT          44 24  0 41.67 61.230  6.00  0.00  5.230
  74 TATTAATATTCCTGTCCCTGTGCCT         43 25  0 40.00 61.200  8.00  0.00  6.200
  75 ATATTAATATTCCTGTCCCTGTGCCT        42 26  0 38.46 61.365 10.00  0.00  7.365
  76 AATATTAATATTCCTGTCCCTGTGCCT       41 27  0 37.04 62.311 12.00  0.00  9.311
  77 ATATTCCTGTCCCTGTGCC               48 19  0 52.63 57.370  4.00  1.00  3.630
  78 AATATTCCTGTCCCTGTGCC              47 20  0 50.00 58.864  6.00  1.00  1.136
  79 TAATATTCCTGTCCCTGTGCC             46 21  0 47.62 58.917  6.00  1.00  2.083
  80 TTAATATTCCTGTCCCTGTGCC            45 22  0 45.45 60.204  6.00  1.00  2.204
  81 ATTAATATTCCTGTCCCTGTGCC           44 23  0 43.48 60.438  6.00  1.00  3.438
  82 TATTAATATTCCTGTCCCTGTGCC          43 24  0 41.67 60.432  8.00  1.00  4.432
  83 ATATTAATATTCCTGTCCCTGTGCC         42 25  0 40.00 60.638 10.00  1.00  5.638
  84 AATATTAATATTCCTGTCCCTGTGCC        41 26  0 38.46 61.650 12.00  1.00  7.650
  85 AAATATTAATATTCCTGTCCCTGTGCC       40 27  0 37.04 62.579 12.00  1.00  9.579
  86 ATTAATATTCCTGTCCCTGTGC            44 22  0 40.91 57.155  6.00  2.00  4.845
  87 TATTAATATTCCTGTCCCTGTGC           43 23  0 39.13 57.263  8.00  2.00  5.737
  88 ATATTAATATTCCTGTCCCTGTGC          42 24  0 37.50 57.627 10.00  2.00  6.373
  89 AATATTAATATTCCTGTCCCTGTGC         41 25  0 36.00 58.823 12.00  2.00  6.177
  90 AAATATTAATATTCCTGTCCCTGTGC        40 26  0 34.62 59.917 12.00  2.00  6.083
  91 CAAATATTAATATTCCTGTCCCTGTGC       39 27  0 37.04 62.049 12.00  2.00  9.049
  92 CAAATATTAATATTCCTGTCCCTGTG        39 26  0 34.62 59.176 12.00  1.00  6.824
  93 TCAAATATTAATATTCCTGTCCCTGTG       38 27  0 33.33 60.641 12.00  1.00  7.641
  94 TCAAATATTAATATTCCTGTCCCTGT        38 26  0 30.77 58.425 12.00  0.00  7.575
  95 CTCAAATATTAATATTCCTGTCCCTGT       37 27  0 33.33 59.222 12.00  0.00  7.778
  96 TCAAATATTAATATTCCTGTCCCTG         38 25  0 32.00 57.690 12.00  1.00  7.310
  97 CTCAAATATTAATATTCCTGTCCCTG        37 26  0 34.62 58.540 12.00  1.00  7.460


	program		anycdf

!	plots any item of wind/waves data or CDF data

	implicit	integer*4 (a-z)

	ok = 1
	if (ok) ok = get_set_tm_stream()
	TYPE*,'GOING TO COLLECT EVENT DATA'
	if (ok) ok = wait_for_events()

	end
	options/extend_source
!------------------------------------------------------------------------------
	integer*4	function	get_set_tm_stream()
c	implicit	none
	include		'wind_examples:wind_tm_routine_def.for'
	include		'wind_examples:wind_return_code_def.for'
	integer*4	ok,okt
	character*4	event,pa(9)
	integer*4	iq,i,j,k,n,iterm,nchgp,npt,np,nday,isrc
	integer*4	iw
	REAL		XSPEC(1024,5)
	integer*4	get_stream_name
	integer*4	wait_for_events			! an entry point
	integer*4	err_count
	character*8	YYYYMMDD
	character*80	stream
	parameter	size=1024
	integer*4	return_size
	integer*4	raw(size)
	integer*4	mantissa(size)
	integer*4	gain(size)
	integer*4	pwrdb(size)    ! actually, .5 db steps
	integer*4	fft_channel
	integer*4	temp_waves
	character*32	s
	real*8		scet8,scetlast,scetspin,tdiff
	character*32	s_scet
	integer*4	scet(2)
	integer*4	ch, chhk, major, minor,itmcorr,iraw
	character*80	file
	character*10	title(4)
	character*32	item
	integer*4	ios,yyyy,idoy,msec
	integer*4	NHRMN,IPNT,LAST,NPTMX,N1,N2,NFILL,NPPL
	REAL		PTIME,DELT,DELTS,DPUTIME,PHASE,SPINRATE
	REAL		tstart,eltime,evtime,tend,tintv
	REAL		FFTSPACE(4),COUNT(4),SPACE
	real		nhist(100,10),vdata(1024),dbspec(1024)
	real		ddata(1024)
	integer*2	pwrl
	integer*2	pwrlt(1000,511)
	integer*4 	ncount
!

	common /fftblk/ gain,mantissa,pwrdb
	COMMON /PLTPAR/ ITERM,NDAY,IPNT(4),ITMCORR,IDOY
	COMMON /SHBLK/ PTIME(1000)
	COMMON /SPBLK/ PWRW(1024),PWRNW(1024),FDATA(1024),VDATA
	common /headblk/ major,minor,fft_channel,isrc,s_scet,title,scet8
!
	DATA ITMCORR /0/             ! 1 = CORRECT FOR TIME, 0 = PLOT
C					CONSECUTIVE SPECTRA
	data ncount /0/
	DATA IPNT /4*0/
	DATA PA /'EXAC','EYAC','EZAC','EXDC','EYDC','EZDC',
     1		'BX','BY','BZ'/
	DATA JP /0/
	DATA IRAW /0/
	DATA TWOPI /6.2831853/
	DATA NTPLOTS /0/
C
	write(6,*) 'type year,month,day of month  e.g. 19960419'
	READ(5,A) YYYYMMDD
	WRITE(STREAM,30) YYYYMMDD
 30	FORMAT('wi_lz_wav_',A8,'_v*.dat')
	PRINT*,'in get_stream_name, file= ',STREAM

	ok = w_channel_open(ch,stream)
	if (.not. ok) stop 'cannot open tm channel'

	write(6,*) 'type hr,min to start,end, e.g. 0414,0800'
	read(5,*) nhrmn,last
	type*,nhrmn,last
	tstart = (nhrmn/100) + mod(nhrmn,100)/60.
	tlast = (last/100) + mod(last,100)/60.
	write(6,4)
	write(6,6)
	read(5,3) iq, main_ch
	nchgp = 1
	if(main_ch.gt.2) nchgp = 2
	if(main_ch.gt.6) nchgp = 3
	type*,'channel to plot and group(hi,mid,lo)',main_ch,nchgp
 3	format(q,i10)
 4	format(1x,'enter channel number for first plot')
 6	format(1x,'(other channels at same speed will be saved)')
 5	format(q,a)
	do n = 1,4
	  title(n) = '          '
	  fftspace(n) = 0.
	  count(n) = 1.E-8
	enddo

	ok = w_channel_filename(ch,file)
	print*,'file',file

	scet8 = 0.
	call w_channel_position(ch,scet8)
	nday = scet8
	type*,'first channel position ',scet8,' ch',ch
	scet8 = dfloat(nday) + ((nhrmn/100) + mod(nhrmn,100)/60.)/24.
	type*,'set channel position to',scet8,' ch',ch
	scetlast= dfloat(nday) + ((last/100) + mod(last,100)/60.)/24.
C**********  TEMPORARY CODE TO GET PAST START
	OK = WIND_TM_GET_MFMF(CH,MAJOR,MINOR)
	MAJOR = MAJOR+1
	OK = WIND_TM_GET_WORD(CH,MAJOR,MINOR,24,I)
C*********** END OF TEMPORARY CODE
	call w_channel_position(ch,scet8)
	type*,'channel position set to',scet8

c 	ok = wind_tm_get_mfmf(ch,major,minor)
c	if (.not. ok) stop 'cannot get stream position'

	get_set_tm_stream = 1
	return

	!----------------------------------------------------------------------
	entry	wait_for_events()
c
	  event = 'FFT'
	  if(nchgp.eq.1) event = 'FFTH'
	  if(nchgp.eq.1) iw = 1
	  if(nchgp.eq.2) event = 'FFTM'
	  if(nchgp.eq.2) iw = 3
	  if(nchgp.eq.3) event = 'FFTL'
	  if(nchgp.eq.3) iw = 7
c
c	  find the first event in a set of channels, for time
c
 120	  ok = w_event(ch,event)
	  item = 'channel_number'
	  okt = w_item_i4(ch, item, fft_channel, 1, return_size)
	  if(fft_channel.ne.iw) go to 120
c************test of spin phase
C	phsav = 0.
C	do ix = 1,100
C	   call w_channel_position(ch,scetlast)
	   item = 'WIND_SPIN_PHASE_R4'
	   ok = w_item_r4(ch, item, PHASE, 1, return_size)
	   item = 'WIND_SPIN_scet_R8'
C	   ok = w_item_r8(ch, item, scetspin, 1, return_size)
	   item = 'wind_spin_rate_r4'
	   ok = w_item_r4(ch, item, spinrate, 1, return_size)
	print*,'spinrate',spinrate
	write(88,*) 'phase,scet,rate',phase,scetspin,spinrate
c
c	calculate spin phase at start of event
c
C	   tdiff = 864.D02*(scetlast - scetspin)
C	   phdiff = tdiff*spinrate
C	   ph1 = phase
C	   if(phdiff.lt.0.) then
C		ph1 = ph1 + phdiff
C	        dowhile (ph1.lt.0.)
C		  ph1 = ph1+twopi
C		enddo
C		ph1 = amod(ph1,twopi)
C	   else
C		ph1 = amod(ph1 + phdiff,twopi)
C	   endif
c
C
C
C	print*,'position,phase,time,del',scetlast,phase,scetspin
C     1    ,phdiff,ph1-phsav
C	   phsav = ph1
C	   scetlast = scetlast + .5d00/864.d02
C	enddo
C	scetlast= dfloat(nday) + ((last/100) + mod(last,100)/60.)/24.
C	if(1) stop
c*******
	  if(ok.eq.82) then
		PRINT*,'END OF FILE'
		print*,'rawcount',rawcount
		print*,'fftcount',fftcount
		stop
	  endif
C
C	THIS IS TO ACCOMODATE THE EARLY FLIGHT SOFTWARD, WHICH HAD ONLY
C	FFT AS AN EVENT, AND WAS NOT SEPARATED INTO H,M AND L
C
	  NEWOLD = 0
	  IF(NCHGP.EQ.0) THEN
		NCHGP = 3
	        NEWOLD = 1
	  ENDIF
	  print*,'collect events: ',event

	   item = 'EVENT_SCET'
	   ok = w_item_i4(ch, item, scet, 2, return_size)
C	   if (.not. ok) type *, 'cannot get item ', item, ', ok=', ok
	   evtime = (scet(2)/10000) + (mod(scet(2),10000)/100)/60.
     1		+ mod(scet(2),100)/3600.
	   type*,'first event at',scet,'  evtime',evtime

C
	   item = 'EVENT_SCET_R8'
	   ok = w_item_r8(ch, item, scet8, 1, return_size)
C	   if (.not. ok) type *, 'cannot get item ', item, ', ok=', ok
	   call w_ur8_to_ydoy(scet8,yyyy,idoy,msec)
c
	  go to 110

	! this is the main program loop

 100	   continue

c	  if( w_end_of_file(ch) ) then

           ok = w_event(ch,event)
	   if (.not. ok) then
	      type *, char(7), '******** missing packet in event ********'
	      type *, 'Cannot get event at MF.mf: ', major, minor
	      err_count = err_count + 1
	      if (err_count .lt. 2) goto 100
	      if (err_count .ge. 2) goto 200
	   end if

 110	  CONTINUE
C
	   ! now get the items

	   item = 'channel_number'
	   ok = w_item_i4(ch, item, fft_channel, 1, return_size)
C
	   item = 'WIND_SPIN_PHASE_R4'
	   ok = w_item_r4(ch, item, PHASE, 1, return_size)
C
	   item = 'WIND_SPIN_scet_R8'
	   ok = w_item_r8(ch, item, scetspin, 1, return_size)
C
	   item = 'wind_spin_rate_r4'
	   ok = w_item_r4(ch, item, spinrate, 1, return_size)
C
	   item = 'EVENT_SCET'
	   ok = w_item_i4(ch, item, scet, 2, return_size)
c

	   item = 'EVENT_SCET_frctn'
	   ok = w_item_i4(ch, item, msec, 1, return_size)
c
	   item = 'EVENT_SCET_R8'
	   ok = w_item_R8(ch, item, SCET8, 1, return_size)
c	   if(scet8.gt.scetlast) stop
	   if(scet8.gt.scetlast) go to 200
c
	   item = 'DPU_MAJOR_FRAME'
	   ok = w_item_I4(ch, item, MAJOR, 1, return_size)
	   item = 'DPU_MINOR_FRAME'
	   ok = w_item_I4(ch, item, MINOR, 1, return_size)
C
	   item = 'SOURCE'
	   ok = w_item_i4(ch, item, ISRC, 1, return_size)

	   write(s,'(i8.8,i6.6)',iostat=ios) scet(1), scet(2)
	   s_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
	1	s(9:10)//':'//s(11:12)//':'//s(13:14)
c
c	  	CALL TSPPLOT(MAIN_CH)
c		call tplot(ch,isrc)
		print*,'fftcount',fftcount
		print*,'rawcount',rawcount
C	   IF(1) STOP
	return
	end


! ******************************************************************************************************************************** !
! SETUP BioGeM
! ******************************************************************************************************************************** !
SUBROUTINE initialise_biogem(                       &
     & dum_saln0,dum_rhoair,dum_cd,dum_ds,dum_dphi, &
     & dum_usc,dum_dsc,dum_fsc,dum_rh0sc,           &
     & dum_rhosc,dum_cpsc,dum_solconst,dum_scf,     &
     & dum_ips,dum_ipf,dum_ias,dum_iaf,dum_jsf,     &
     & dum_k1,                                      &
     & dum_dz,dum_dza,                              &
     & dum_c,dum_cv,dum_s,dum_sv,                   &
     & dum_ts,                                      &
     & dum_ts1,                                     &
     & dum_sfcatm1,                                 &
     & dum_sfxatm1,                                 &
     & dum_sfcocn1,                                 &
     & dum_sfxocn1,                                 &
     & dum_sfcsed1,                                 &
     & dum_sfxsed1                                  &
     & )
  USE biogem_lib
  USE biogem_data
  USE biogem_data_ascii
  USE genie_util, ONLY: check_iostat
  ! ---------------------------------------------------------- !
  ! DUMMY ARGUMENTS
  ! ---------------------------------------------------------- !
  REAL,INTENT(in)::dum_saln0,dum_rhoair,dum_cd,dum_ds,dum_dphi   !
  real,INTENT(in)::dum_usc,dum_dsc,dum_fsc,dum_rh0sc             !
  real,INTENT(in)::dum_rhosc,dum_cpsc,dum_solconst,dum_scf       !
  INTEGER,INTENT(in),DIMENSION(n_j)::dum_ips,dum_ipf             !
  INTEGER,INTENT(in),DIMENSION(n_j)::dum_ias,dum_iaf             !
  INTEGER,INTENT(in)::dum_jsf                                    !
  integer,DIMENSION(n_i,n_j),INTENT(in)::dum_k1                  !
  REAL,DIMENSION(n_k),INTENT(in)::dum_dz,dum_dza                 !
  REAL,DIMENSION(0:n_j),INTENT(in)::dum_c,dum_cv,dum_s,dum_sv    !
  REAL,DIMENSION(intrac_ocn,n_i,n_j,n_k),INTENT(inout)::dum_ts   ! NOTE: number of tracers in GOLDSTEIN used in dimension #1
  REAL,DIMENSION(intrac_ocn,n_i,n_j,n_k),INTENT(inout)::dum_ts1  ! NOTE: number of tracers in GOLDSTEIN used in dimension #1
  real,intent(inout),dimension(n_atm,n_i,n_j)::dum_sfcatm1       ! atmosphere-surface tracer composition; occ grid
  real,intent(inout),dimension(n_atm,n_i,n_j)::dum_sfxatm1       ! atmosphere-surface fluxes; ocn grid
  real,intent(inout),dimension(n_ocn,n_i,n_j)::dum_sfcocn1       ! sediment-surface ocean tracer composition; ocn grid
  real,intent(inout),dimension(n_ocn,n_i,n_j)::dum_sfxocn1       ! sediment-surface (sed->ocn) fluxes; ocn grid
  real,intent(inout),dimension(n_sed,n_i,n_j)::dum_sfcsed1       ! sediment-surface sediment composition; ocn grid
  real,intent(inout),dimension(n_sed,n_i,n_j)::dum_sfxsed1       ! sediment-surface (ocn->sed) fluxes; ocn grid
  ! ---------------------------------------------------------- !
  ! DEFINE LOCAL VARIABLES
  ! ---------------------------------------------------------- !
  integer::loc_iou
  integer::i,j,k,n
  integer::n_wet_grid,loc_k1
  ! ---------------------------------------------------------- !
  ! START
  ! ---------------------------------------------------------- !
  print*,'======================================================='
  print*,' >>> Initialising BIOGEM ocean biogeochem. module ...'
  ! ---------------------------------------------------------- ! load GOIN
  call sub_load_goin_biogem()
  ! ---------------------------------------------------------- ! set time
  ! NOTE: modify 'par_misc_t_start' according to the run-time accumulated in any requested restart,
  !       so that the time that BioGeM starts with is the same as the requested start time
  !       (BioGeM calculates its internal time as equal to par_misc_t_start + elapsed GOLDSTEIn time,
  !        BUT, elapsed GOLDSTEIn time will include any accumulated restart time,
  !        hence accumulated restart time is subtracted from par_misc_t_start)
  ! NOTE: I'm sure that this doesn't make any sense at all ... :(
  if (ctrl_misc_t_BP) then
     par_misc_t_end = par_misc_t_start - par_misc_t_runtime
  else
     par_misc_t_end = par_misc_t_start + par_misc_t_runtime
  end if
  ! ---------------------------------------------------------- !
  ! *** copy GOLDSTEIn parameters ***
  ! ---------------------------------------------------------- !
  ! ---------------------------------------------------------- ! copy dimensional scale factors for ocean
  goldstein_usc    = dum_usc
  goldstein_dsc    = dum_dsc
  goldstein_fsc    = dum_fsc
  goldstein_rh0sc  = dum_rh0sc
  goldstein_rhosc  = dum_rhosc
  goldstein_cpsc   = dum_cpsc
  ! ---------------------------------------------------------- ! copy miscellaneous constants
  ! NOTE: use identical value of pi to avoid possible GOLDETSIn/BioGeM mis-match in the calculation of ocean areas and volumes
  goldstein_saln0    = dum_saln0
  goldstein_rhoair   = dum_rhoair
  goldstein_cd       = dum_cd
  goldstein_ds       = dum_ds
  goldstein_dphi     = dum_dphi
  goldstein_scf      = dum_scf
  phys_solar_constant = dum_solconst
  ! ---------------------------------------------------------- ! copy ocean positions
  goldstein_jsf = dum_jsf
  goldstein_ips(:) = dum_ips(:)
  goldstein_ipf(:) = dum_ipf(:)
  goldstein_ias(:) = dum_ias(:)
  goldstein_iaf(:) = dum_iaf(:)
  ! ---------------------------------------------------------- ! copy grid information
  goldstein_k1(:,:) = dum_k1(:,:)
  goldstein_dz(:)  = dum_dz(:)
  goldstein_dza(:) = dum_dza(:)
  goldstein_c(:)   = dum_c(:)
  goldstein_cv(:)  = dum_cv(:)
  goldstein_s(:)   = dum_s(:)
  goldstein_sv(:)  = dum_sv(:)
  ! ---------------------------------------------------------- !
  ! *** define ts->ocn offset and copy <ts> array information ***
  ! ---------------------------------------------------------- !
  ! ---------------------------------------------------------- ! define ofset between GOLDSTEIn tracer units and BioGeM
  ! => temperature is degrees C in GOLDSTEIn, but K in BioGeM
  ! => salinity is as a relative deviation (o/oo) (from saln0) in GOLDSTEIn, but absolute (o/oo) in BioGeM
  tstoocn_offset(:) = 0.0
  tstoocn_offset(1) = const_zeroC
  tstoocn_offset(2) = goldstein_saln0
  ! ---------------------------------------------------------- !
  ! *** set-up biogem-sedgem and biogem-atchem interfacing ***
  ! ---------------------------------------------------------- !
  ! ---------------------------------------------------------- ! initialize interface arrays
  dum_sfcatm1(:,:,:) = 0.0
  dum_sfxatm1(:,:,:) = 0.0
  dum_sfcocn1(:,:,:) = 0.0
  dum_sfxocn1(:,:,:) = 0.0
  dum_sfcsed1(:,:,:) = 0.0
  dum_sfxsed1(:,:,:) = 0.0
  ! ---------------------------------------------------------- ! define relationships between tracers
  CALL sub_def_tracerrelationships()
  ! ---------------------------------------------------------- !
  !  INITIALIZE ARRAYS -- EXPLICIT GRID
  ! ---------------------------------------------------------- !
  ! NOTE: check for problems allocating array space
  !- --------------------------------------------------------- ! explicit grid: restoring forcing
  ALLOCATE(force_restore_locn(n_l_ocn,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(force_restore_locn_I(n_l_ocn,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(force_restore_locn_II(n_l_ocn,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  !- --------------------------------------------------------- ! flux grid: restoring forcing
  ALLOCATE(force_flux_locn(n_l_ocn,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(force_flux_locn_I(n_l_ocn,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(force_flux_locn_II(n_l_ocn,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  !- --------------------------------------------------------- ! data saving
  if (ctrl_data_save_3d_sig) then
     ALLOCATE(int_misc_3D_sig(n_l_ocn,n_i,n_j,n_k),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
  end if
  ! ---------------------------------------------------------- !
  !  INITIALIZE ARRAYS -- VECTORIZED -- 3D
  ! ---------------------------------------------------------- !
  ! NOTE: check for problems allocating array space
  ! ---------------------------------------------------------- ! calculate array grid point dimension
  ! count number of wet grid points
  n_vocn = 0
  DO i=1,n_i
     DO j=1,n_j
        IF (n_k >= goldstein_k1(i,j)) THEN
           n_vocn = n_vocn + 1
        end if
     end do
  end do
  ! ---------------------------------------------------------- ! allocate arrays: 3D
  ALLOCATE(vocn(1:n_vocn),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(vdocn(1:n_vocn),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(vbio_remin(1:n_vocn),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(vbio_part(1:n_vocn),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(vdbio_part(1:n_vocn),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(vphys_ocn(1:n_vocn),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  allocate(matrix_exp(1:n_vocn),stat=alloc_error)		! JDW: allocate matrix experiment storage array in one dimension
  call check_iostat(alloc_error,__LINE__,__FILE__)
  do n=1,n_vocn
     allocate(vocn(n)%mk(1:n_l_ocn,1:n_k),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     allocate(vdocn(n)%mk(1:n_l_ocn,1:n_k),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     allocate(vbio_remin(n)%mk(1:n_l_ocn,1:n_k),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     allocate(vbio_part(n)%mk(1:n_l_sed,1:n_k),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     allocate(vdbio_part(n)%mk(1:n_l_sed,1:n_k),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     allocate(vphys_ocn(n)%mk(1:n_phys_ocn,1:n_k),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     allocate(matrix_exp(n)%mk(1:6,1:n_k),stat=alloc_error)		! JDW: allocate inner matrix array for *6* colour tracers
     call check_iostat(alloc_error,__LINE__,__FILE__)
  end do
  ! ---------------------------------------------------------- ! initialize arrays: 3D
  ! NOTE: explicit grid allocated arrays are initialized through the call to sub_init_force
  vocn(:)       = fun_lib_init_vocn()
  vdocn(:)      = fun_lib_init_vocn()
  vbio_remin(:) = fun_lib_init_vocn()
  vbio_part(:)  = fun_lib_init_vsed()
  vdbio_part(:) = fun_lib_init_vsed()
  vphys_ocn(:)  = fun_lib_init_vocn_n(n_phys_ocn)
  matrix_exp(:) = fun_lib_init_vocn()		! JDW: initialize matrix experiment array
  ! ---------------------------------------------------------- !
  !  INITIALIZE ARRAYS -- VECTORIZED -- 2D
  ! ---------------------------------------------------------- !
  ! NOTE: check for problems allocating array space
  ! ---------------------------------------------------------- ! calculate array grid point dimension
  n_vocnatm = 0
  DO i=1,n_i
     DO j=1,n_j
        n_vocnatm = n_vocnatm + 1
     end do
  end do
  ! ---------------------------------------------------------- ! allocate arrays: 2D
  ALLOCATE(vphys_ocnatm(1:n_vocnatm),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  do n=1,n_vocnatm
     allocate(vphys_ocnatm(n)%m(1:n_phys_ocnatm),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
  end do
  ! ---------------------------------------------------------- !
  !  INITIALIZE BIOGEM
  ! ---------------------------------------------------------- !
  IF (ctrl_debug_lvl2) print*, ' '
  IF (ctrl_debug_lvl2) print*, 'DEBUG LEVEL #2: initialize BioGeM'
  ! ---------------------------------------------------------- ! initialize arrays (1)
  IF (ctrl_debug_lvl2) print*, 'initialize arrays'
  CALL sub_init_force()
  CALL sub_init_diag()
  IF (ctrl_audit) CALL sub_init_audit()
  ! ---------------------------------------------------------- ! init ocean and ocean-atmosphere interfacing grids and physics
  IF (ctrl_debug_lvl2) print*, 'initialize ocean and ocean-atmosphere interfacing grids and physics'
  CALL sub_init_phys_ocn()
  CALL sub_init_phys_ocnatm()
  !>>> ALT VECTOR FORM
  CALL sub_data_init_phys_ocn()
  CALL sub_data_init_phys_ocnatm()
  !<<< ALT VECTOR FORM
  ! ---------------------------------------------------------- !
  ! load default values for ocean, atmosphere, and sediment tracers and and initialize tracer arrays and options
  IF (ctrl_debug_lvl2) print*, 'load default values for ocean, atmosphere, and sediment tracers'
  CALL sub_init_tracer_ocn_comp()
  CALL sub_init_tracer_forcing_atm()
  CALL sub_init_tracer_forcing_ocn()
  CALL sub_init_tracer_forcing_sed()
  call sub_biogem_copy_tstoocn(dum_ts)
  ! initialize biological scheme
  IF (ctrl_debug_lvl2) print*, 'initialize biological sub-system'
  call sub_init_bio()
  ! ?
  IF (trim(opt_misc_geoeng) /= 'NONE') THEN
     ! initialize geoengineering
     IF (ctrl_debug_lvl2) print*, 'initialize geoengineering'
     call sub_init_misc2D()
  end IF
  ! initialize geoghermal heat input
  if (ctrl_force_Fgeothermal2D) then
     call sub_init_force_Fgeothermal()
  end if
  ! calculate all the tracer relationship indices
  IF (ctrl_debug_lvl2) print*, 'calculate all the primary tracer relationship indices'
  call sub_calc_tracerrelationships_i()
  ! update relationships between tracers
  IF (ctrl_debug_lvl2) print*, 'update relationships between tracers'
  call sub_data_update_tracerrelationships
  ! data save meta config
  IF (ctrl_debug_lvl2) print*, 'set basic data save config'
  call sub_adj_par_save()
  ! set meta-options and verify self-consistency of chosen parameters
  IF (ctrl_debug_lvl2) print*, 'verify self-consistency of chosen parameters'
  call sub_check_par_biogem()
  ! initialize carbon cycle sub-systems
  IF (ctrl_debug_lvl2) print*, 'initialize carbon cycle sub-systems'
  CALL sub_init_carb()
  ! initialize gas solubility
  IF (ctrl_debug_lvl2) print*, 'initialize gas solubility'
  CALL sub_init_solconst()
  ! initialize geochem lookup tables
  IF (ctrl_debug_lvl2) print*, 'initialize geochem lookup tables'
  SELECT CASE (trim(opt_geochem_Fe))
  CASE ('lookup_4D')
     CALL sub_data_init_lookup_4D_Fe()
  end SELECT
  ! ---------------------------------------------------------- ! set up redox save/reporting
  CALL sub_init_redox()
  ! ---------------------------------------------------------- ! initialize arrays (2)
  IF (ctrl_debug_lvl2) print*, 'initialize data saving arrays'
  CALL sub_init_int_timeslice()
  CALL sub_init_int_timeseries()
  ! ---------------------------------------------------------- ! initialize the time scale save string
  IF (ctrl_debug_lvl2) print*, 'initialize the time scale save string'
  CALL sub_init_char()
  ! initialize basic data saving
  IF (ctrl_debug_lvl2) print*, 'initialize basic data saving'
  CALL sub_init_data_save()
  ! open units for runtime file I/O
  IF (ctrl_debug_lvl2) print*, 'open units for runtime file I/O'
  IF ((opt_append_data.eqv..FALSE.).OR.(ctrl_continuing.eqv..FALSE.)) THEN
     IF (ctrl_data_save_sig_ascii)  CALL sub_init_data_save_runtime()
  ENDIF
  ! initialize system forcings
  IF (ctrl_debug_lvl2) print*, 'initialize system forcings'
  CALL sub_init_force_restore_atm()
  CALL sub_init_force_flux_atm()
  CALL sub_init_force_restore_ocn()
  CALL sub_init_force_flux_ocn()
  !CALL sub_init_force_restore_sed()
  CALL sub_init_force_flux_sed()
  if (ctrl_force_solconst) then
     ! initialize time-dependent solar forcing
     IF (ctrl_debug_lvl2) print*, 'initialize time-dependent solar forcing'
     call sub_init_force_solconst()
  end if
  ! initialize orbital data saving
  IF (ctrl_debug_lvl2) print*, 'initialize orbital data saving'
  CALL sub_init_data_save_orb()

  ! *** INITILAIZE NETCDF  ***
  IF (ctrl_debug_lvl2) print*, 'initialize netCDF'
  ! set filenames
  string_ncout2d    = TRIM(par_outdir_name)//'fields_biogem_2d.nc'
  string_ncout3d    = TRIM(par_outdir_name)//'fields_biogem_3d.nc'
  string_nctsint    = TRIM(par_outdir_name)//'timeseries_biogem.nc'
  string_nctsi      = TRIM(par_outdir_name)//'ts_biogem_int.nc'
  string_nctsglob   = TRIM(par_outdir_name)//'ts_biogem_glob.nc'
  string_ncout3dsig = TRIM(par_outdir_name)//'fields_biogem_3dts.nc'
  ! initialise 2d and 3d netcdf files
  IF (ctrl_continuing.AND.opt_append_data) THEN
     OPEN(unit=in,status='old',file=TRIM(par_rstdir_name)//'netcdf_record_numbers',form='formatted',action='read')
     READ(unit=in,fmt='(i6)') ncout2d_ntrec,ncout3d_ntrec
     close(unit=in)
  ELSE
     call sub_init_netcdf(trim(string_ncout2d),loc_iou,2)
     ncout2d_iou = loc_iou
     ncout2d_ntrec = 0
     call sub_init_netcdf(trim(string_ncout3d),loc_iou,3)
     ncout3d_iou = loc_iou
     ncout3d_ntrec = 0
     if (ctrl_data_save_3d_sig) then
        call sub_init_netcdf(trim(string_ncout3dsig),loc_iou,4)
        ncout3dsig_iou = loc_iou
        ncout3dsig_ntrec = 0
     end if
  ENDIF

  ! JDW: initialise matrix netcdf output
  if(ctrl_data_diagnose_TM)THEN
    ! find number of wet grid-points
    n_wet_grid=0
    do n=1,n_vocn,1
      loc_k1 = vocn(n)%k1
        do k=n_k,loc_k1,-1
          n_wet_grid=n_wet_grid+1
        end do
    end do
    ! initialise matrix netcdf file
    call sub_init_netcdf_TM(n_wet_grid)
  end if

  ! *** load restart information ***
  IF (ctrl_continuing) then
     call sub_data_load_rst()
  end if

  ! *** initialize tracer auditing ***
  ! carry out initial tracer inventory audit
  IF (ctrl_audit) THEN
     IF (ctrl_debug_lvl2) print*, 'initialize tracer auditing'
     audit_ocn_init(:) = fun_calc_ocn_tot()
     audit_ocn_old(:)  = audit_ocn_init(:)
  end if

  ! *** write ocean tracer data to GOLDSTEIn arrays ***
  IF (ctrl_debug_lvl2) print*, 'initialize GOLDSTEIN biogeochem tracers'
  call sub_biogem_copy_ocntots(dum_ts,dum_ts1)
  if (ctrl_force_GOLDSTEInTS) call sub_biogem_copy_ocntotsTS(dum_ts,dum_ts1)

  ! ############################################################################################################################# !
!!! *** TESTING ***
  vocn(:)=fun_lib_conv_ocnTOvocn(ocn(:,:,:,:))
  ocn = 0.0
  ocn(:,:,:,:)=fun_lib_conv_vocnTOocn(vocn(:))
  ! ############################################################################################################################# !

  ! *** enable BioGeM ***
  par_misc_t_go = .TRUE.

  print*,' <<< Initialisation complete'
  print*,'======================================================='

  return

END SUBROUTINE initialise_biogem
! ******************************************************************************************************************************** !


C
C	$Id: dashdc.f,v 1.7 2008-07-27 00:23:03 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE DASHDC (IPAT,JCRT,JSIZE)
C
C
C
C
C
C
      COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE,
     1    ICLOSE
C
C USER ENTRY POINT.
C DASHDC GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS
C SPECIFIED IN ITS ARGUMENTS. THIS INTERNAL REPRESENTATION IS PASSED
C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1.
C
      CHARACTER*(*) IPAT
      CHARACTER*1   ICR
      CHARACTER*16  IPC(100)
C
C DASHD1 AND DASHD2 ARE USED
C FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB, DASHDC AND CFVLD.
C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBDX.
C
      COMMON /DASHD1/  ISL,  L,  ISIZE,  IP(100),  NWDSM1,  IPFLAG(100)
     1                 ,MNCSTR, IGP
      COMMON /DASHD2/  IPC
C
C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB AND DASHDC.
C IT IS INITIALIZED IN DASHBDX.
C
      COMMON /DDFLAG/ IFCFLG
C
C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD)
C WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED.
C IT IS INITIALIZED IN DASHBDX AND REFERENCED IN CFVLD.
C
      COMMON /DCFLAG/ IFSTFL
C
C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE
C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED.
C IT IS INITIALIZED IN DASHBDX AND REFERENCED IN FDVDLD.
C
      COMMON /DFFLAG/ IFSTF2
C
C LOCAL VARIABLES TO DASHDB AND DASHDC ARE SAVED IN DSAVE6
C FOR THE NEXT CALL
C
      COMMON /DSAVE6/ MASK, NCHRWD, NBWD, MNCST1
C
C Make definitions of a blank, a gap, and a solid externally visible.
C
      COMMON /BLGASO/ IBLK,IGAP,ISOL
      CHARACTER*1     IBLK,IGAP,ISOL
C
C SAVE ALL VARIABLES
C
      SAVE
C
C NPD IS THE NUMBER OF WORDS IN IP
C
      DATA NPD/100/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
      CALL DASHBD
C
C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR
C
      CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDC', 'VERSION  1')
C
C     NC IS THE NUMBER OF CHARACTERS IN IPAT
C
      NC = LEN(IPAT)
      IF (IFCFLG .EQ. 2) GOTO 10
C
C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBDX ARE LOADED CORRECTLY
C
      IF (MNCSTR .EQ. 15) GOTO 6
      CALL SETER('DASHDC -- BLOCKDATA DASHBDX APPARENTLY NOT LOADED CORR
     1ECTLY',1,2)
    6 CONTINUE
C
C INITIALIZATION
C
      MNCST1 = MNCSTR + 1
C
C MASK IS AN ALL SOLID PATTERN TO BE PASSED TO OPTN (65535=177777B).
C
      MASK=IOR(ISHIFT(32767,1),1)
C
C
      IFCFLG = 2
C
C NCHRTS - NUMBER OF CHARS IN THIS HOLLERITH STRING.
C L      - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY.
C ISL    - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1).
C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS
C          CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED.
C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD
C          IS CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED.
C
   10 CONTINUE
      NCHRTS = 0
      L = 0
      ISL = 0
      IFSTFL = 1
      IFSTF2 = 1
C
C RETRIEVE THE RESOLUTION AS SET BY THE USER.
C
      CALL GETUSV('XF',LXSAVE)
      CALL GETUSV('YF',LYSAVE)
C
C IADJUS - TO ADJUST NUMBERS TO THE GIVEN RESOLUTION.
C
      IADJUS = ISHIFT(1,15-LXSAVE)
      ICRT = JCRT*IADJUS
      ISIZE = JSIZE
      CHARW = REAL(ISIZE*IADJUS)
      IF (ISIZE .GT. 3) GO TO 30
      CHARW = 256. + REAL(ISIZE)*128.
      IF (ISIZE .EQ. 3) CHARW = 768.
C
   30 CONTINUE
      IF (ICRT .LT. 1) GO TO 230
      MODE = 2
C
C START MAIN LOOP
C
C THIS LOOP GENERATES THE IP ARRAY (NEEDED BY CURVED,VECTD,ETC.) FROM
C THE CHARACTER STRING IN IPAT.  EACH ITERATION OF THE LOOP PROCESSES
C ONE CHAR OF IPAT.  A SOLID OR GAP IS CONSIDERED TO BE A TYPE 1 ENTRY,
C AND A LABEL CHARACTER IS CONSIDERED TO BE A TYPE 2 ENTRY.
C
C IN THE CODE, L IS THE NUMBER OF CHANGES IN THE LINESTYLE (FROM GAP
C TO SOLID, SOLID TO CHARACTER, ETC.)  THE IP AND IPFLAG ARRAYS DESCRIBE
C THE LINE TO BE DRAWN, AND THESE ARRAYS ARE INDEXED FROM 1 TO L.  THE
C RELATIONSHIP BETWEEN IP AND IPFLAG IS:
C
C      IPFLAG(N)    IP(N)
C      ---------    -----
C          1        LENGTH (IN PLOTTER ADDRESS UNITS) OF SOLID LINE TO
C                   BE DRAWN.
C          0        NUMBER OF CHARACTERS TO BE PLOTTED.
C         -1        LENGTH (IN PLOTTER ADDRESS UNITS) OF GAP.
C
C THE 160 LOOP HANDLES 5 CASES:
C
C    1.)  CONTINUE TYPE 2 ENTRY (60-80)
C    2.)  START TYPE 2 ENTRY (80-90)
C    3.)  END TYPE 2 ENTRY AND START TYPE 1 ENTRY (90-160)
C    4.)  START TYPE 1 ENTRY, OR SWITCH TYPE 1 ENTRY FROM SOLID TO
C         GAP OR FROM GAP TO SOLID (140-160)
C    5.)  CONTINUE TYPE 1 ENTRY (150-160)
C
      DO 160 J=1,NC
C
C GET NEXT CHAR INTO ICR, RIGHT JUSTIFIED ZERO FILLED.
C
            ICR = IPAT(J:J)
C
C MODE SPECIFIES WHAT THE LAST CHARACTER PROCESSED WAS:
C
C    LAST ICR WAS $ (SOLID),      MODE IS 8
C    LAST ICR WAS ' (GAP),        MODE IS 2
C    LAST ICR WAS HOLLERITH CHAR, MODE IS 5
C
C NMODE SPECIFIES WHAT THE CURRENT CHARACTER TO BE PROCESSED IS:
C
C      ICR     NMODE
C      ---     -----
C       $        1
C       CHAR     0
C       '       -1
C
            NMODE = 0
            IF (ICR .EQ. IBLK) GO TO 160
            IF (ICR .EQ. IGAP) NMODE = -1
            IF (ICR .EQ. ISOL) NMODE = 1
            IF (L.EQ.0 .AND. NMODE.EQ.-1) MODE = 8
C
C NGO DETERMINES WHERE TO BRANCH BASED ON CASE TO BE PROCESSED.
C COMPUTE MODE FOR NEXT ITERATION.
C
            NGO = NMODE+MODE
            MODE = NMODE*3+5
            GO TO (150,80,140,90,60,90,140,80,150),NGO
C
C CHAR TO CHAR
C
C CASE 1) - CONTINUE TYPE 2 ENTRY.
C
   60      IF (NCHRTS .EQ. MNCSTR) GO TO 160
           NCHRTS = NCHRTS + 1
           IP(L) = NCHRTS
           IPC(L)(NCHRTS:NCHRTS) = ICR
           GO TO 160
C
C BLANK OR SOLID TO CHAR
C
C CASE 2) - START STRING ENTRY.  LGBSTR POINTS TO THE GAP WHICH
C           WILL CONTAIN THE STRING.
C
   80      LGBSTR = MIN(L+1,NPD)
           L = MIN(LGBSTR+1,NPD)
           IPFLAG(L) = 0
           NCHRTS    = 1
           IP(L)     = 1
           IPC(L)(NCHRTS:NCHRTS) = ICR
           GO TO 160
C
C CHAR TO SOLID OR GAP
C
C CASE 3) - END STRING ENTRY.  ICR IS A $ OR '.
C
   90      CONTINUE
           IP(LGBSTR) = CHARW*(REAL(NCHRTS) + .5)
           IPFLAG(LGBSTR) = -1
           IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1
C
C BLANK TO SOLID OR SOLID TO BLANK
C
C CASE 4) - START TYPE 1 ENTRY.
C
  140       L = MIN(L+1,NPD)
            IP(L) = 0
C
C ADD TO A BLANK OR SOLID LINE
C
C CASE 5) - CONTINUE TYPE 1 ENTRY.  ICR IS A $ OR '.
C ADD ICRT UNITS TO THE PLOTTER ADDRESS UNITS IN IP(L).
C NMODE INDICATES IF IT IS A GAP OR A SOLID.
C
  150       IP(L) = IP(L) + ICRT
            IPFLAG(L) = NMODE
  160    CONTINUE
C
C IF LAST ICR PROCESSED WAS A LABEL CHARACTER, MUST END STRING
C ENTRY.
C
      IF (NGO.NE.2 .AND. NGO.NE.5 .AND. NGO.NE.8) GO TO 220
      IP(LGBSTR) = CHARW*(REAL(NCHRTS)+.5)
      IPFLAG(LGBSTR) = -1
      IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1
C
C IF IP ARRAY HAS ONLY ONE TYPE 1 ENTRY, SET ISL FLAG.
C
  220 IF (L .GT. 1) RETURN
      IBIG = ISHIFT(1,MAX(LXSAVE,LYSAVE))
      IF (IP(L) .GE. IBIG) GO TO 230
      IF (IPFLAG(L)) 240,240,230
  230 ISL = 1
      RETURN
  240 ISL = -1
      RETURN
      END


subroutine task_dispatch(buff,tag)

! dispathes the messages according to the field sent.

use vars
use microphysics
use sgs
use tracers
implicit none

real buff(*)	! buff for sending data
integer tag	! tag of the message
integer field   ! id of field

field = tag/100000

if(field.eq.1) then

  call task_assign_bnd(u,dimx1_u,dimx2_u,dimy1_u,dimy2_u,nzm,buff,tag)

elseif(field.eq.2) then

  call task_assign_bnd(v,dimx1_v,dimx2_v,dimy1_v,dimy2_v,nzm,buff,tag)

elseif(field.eq.3) then

  call task_assign_bnd(w,dimx1_w,dimx2_w,dimy1_w,dimy2_w,nz,buff,tag)

elseif(field.eq.4) then

  call task_assign_bnd(t,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,buff,tag)

elseif(field.gt.4.and.field.le.4+nsgs_fields) then

  call task_assign_bnd(sgs_field(:,:,:,field-4),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,buff,tag)

elseif(field.gt.4+nsgs_fields.and.field.le.4+nsgs_fields+nsgs_fields_diag) then

  call task_assign_bnd(sgs_field_diag(:,:,:,field-4-nsgs_fields), &
                                                dimx1_d,dimx2_d,dimy1_d,dimy2_d,nzm,buff,tag)

elseif(field.gt.4+nsgs_fields+nsgs_fields_diag.and.field.le.4+nsgs_fields+nsgs_fields_diag+nmicro_fields) then

  call task_assign_bnd(micro_field(:,:,:,field-4-nsgs_fields-nsgs_fields_diag), &
                                                dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,buff,tag)

elseif(field.gt.4+nsgs_fields+nsgs_fields_diag+nmicro_fields.and. &
                        field.le.4+nsgs_fields+nsgs_fields_diag+nmicro_fields+ntracers) then

  call task_assign_bnd(tracer(:,:,:,field-4-nsgs_fields-nsgs_fields_diag-nmicro_fields),&
                                                dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,buff,tag)

end if

end