ACCEPTABLE LEFT PRIMERS
                                  1-based     #               self  self  qual-
   # sequence                       start ln  N   GC%     Tm   any   end   lity
   0 TGTGTCTTGTGGGTGTGTCTG             79 21  0 52.38 60.680  1.00  1.00  1.680
   1 TGTCTTGTGGGTGTGTCTGTT             81 21  0 47.62 59.059  1.00  0.00  1.941
   2 GTGTCTTGTGGGTGTGTCTGTT            80 22  0 50.00 59.972  1.00  0.00  2.028
   3 GAACATGTGTGGCATTGTGT              21 20  0 45.00 57.775  6.00  0.00  2.225
   4 GTGTCTTGTGGGTGTGTCTGT             80 21  0 52.38 58.472  1.00  0.00  2.528
   5 TGTCTTGTGGGTGTGTCTGT              81 20  0 50.00 57.431  1.00  0.00  2.569
   6 GTGTCTTGTGGGTGTGTCTG              80 20  0 55.00 57.431  1.00  1.00  2.569
   7 TGTGTCTTGTGGGTGTGTCT              79 20  0 50.00 57.431  1.00  0.00  2.569
   8 TGTCTTGTGGGTGTGTCTGTTA            81 22  0 45.45 59.108  2.00  2.00  2.892
   9 TTGTGGGTGTGTCTGTTAAACA            85 22  0 40.91 58.997  7.00  7.00  3.003
  10 GTGTCTTGTGGGTGTGTCTGTTA           80 23  0 47.83 59.984  2.00  2.00  3.016
  11 CTTGTGGGTGTGTCTGTTAAACA           84 23  0 43.48 59.981  7.00  7.00  3.019
  12 GAACATGTGTGGCATTGTGTA             21 21  0 42.86 57.880  6.00  2.00  3.120
  13 TGTCTTGTGGGTGTGTCTGTTAA           81 23  0 43.48 60.493  4.00  4.00  3.493
  14 TGTGGGTGTGTCTGTTAAACA             86 21  0 42.86 57.489  7.00  7.00  3.511
  15 TGTGTCTTGTGGGTGTGTCTGT            79 22  0 50.00 61.549  1.00  0.00  3.549
  16 AAACATGTGTGGTATTGTGCA            102 21  0 38.10 57.391  6.00  4.00  3.609
  17 TTGTGGGTGTGTCTGTTAAACAT           85 23  0 39.13 59.319  7.00  5.00  3.681
  18 GAACATGTGTGGCATTGTGTAT            21 22  0 40.91 58.283  6.00  2.00  3.717
  19 TGGGTGTGTCTGTTAAACATGTG           88 23  0 43.48 60.746  7.00  4.00  3.746
  20 TGTGGGTGTGTCTGTTAAACATG           86 23  0 43.48 60.746  7.00  5.00  3.746
  21 TCTTGTGGGTGTGTCTGTTAAA            83 22  0 40.91 58.187  4.00  3.00  3.813
  22 AGCTTCTTGACTGTGTGTTGTG           149 22  0 45.45 58.075  4.00  0.00  3.925
  23 TCTTGTGGGTGTGTCTGTTAAAC           83 23  0 43.48 59.063  5.00  5.00  3.937
  24 GTCTTGTGGGTGTGTCTGTTAAA           82 23  0 43.48 59.063  4.00  3.00  3.937
  25 TGGATGTAGCTTCTTGACTGTG           142 22  0 45.45 58.036  4.00  1.00  3.964
  26 AGCTTCTTGACTGTGTGTTGTGT          149 23  0 43.48 58.981  4.00  0.00  4.019
  27 GGATGTAGCTTCTTGACTGTGTG          143 23  0 47.83 58.925  4.00  0.00  4.075
  28 TGGATGTAGCTTCTTGACTGTGT          142 23  0 43.48 58.925  4.00  1.00  4.075
  29 TTAAACATGTGTGGTATTGTGCA          100 23  0 34.78 58.925  6.00  4.00  4.075
  30 GGGTGTGTCTGTTAAACATGTG            89 22  0 45.45 57.912  7.00  4.00  4.088
  31 TGGGTGTGTCTGTTAAACATGT            88 22  0 40.91 57.912  7.00  6.00  4.088
  32 GTGGGTGTGTCTGTTAAACATG            87 22  0 45.45 57.912  7.00  5.00  4.088
  33 TGTGGGTGTGTCTGTTAAACAT            86 22  0 40.91 57.912  7.00  5.00  4.088
  34 AACATGTGTGGCATTGTGTATACA          22 24  0 37.50 60.103  8.00  8.00  4.103
  35 GTCTTGTGGGTGTGTCTGTTAAAC          82 24  0 45.83 59.875  5.00  5.00  4.125
  36 CATGTGTGGCATTGTGTATACA            24 22  0 40.91 57.850  8.00  8.00  4.150
  37 AAACATGTGTGGTATTGTGCAT           102 22  0 36.36 57.811  6.00  2.00  4.189
  38 GGGTGTGTCTGTTAAACATGTGT           89 23  0 43.48 58.808  7.00  6.00  4.192
  39 GTGGGTGTGTCTGTTAAACATGT           87 23  0 43.48 58.808  7.00  6.00  4.192
  40 ACATGTGTGGCATTGTGTATACA           23 23  0 39.13 58.766  8.00  8.00  4.234
  41 CTTGTGGGTGTGTCTGTTAAACAT          84 24  0 41.67 60.239  7.00  5.00  4.239
  42 GGATGTAGCTTCTTGACTGTGTGT         143 24  0 45.83 59.748  4.00  0.00  4.252
  43 GTTAAACATGTGTGGTATTGTGCA          99 24  0 37.50 59.733  6.00  4.00  4.267
  44 TGTTAAACATGTGTGGTATTGTGC          98 24  0 37.50 59.733  7.00  2.00  4.267
  45 GTCTTGTGGGTGTGTCTGTTAA            82 22  0 45.45 57.635  4.00  4.00  4.365
  46 TAAACATGTGTGGTATTGTGCA           101 22  0 36.36 57.504  6.00  4.00  4.496
  47 TGTGTGTTGTGTATGGATGTAGC          129 23  0 43.48 58.499  2.00  2.00  4.501
  48 TGTGTGTTGTGTATGGATGTAGCT         129 24  0 41.67 59.493  4.00  4.00  4.507
  49 ATGGATGTAGCTTCTTGACTGTG          141 23  0 43.48 58.408  4.00  1.00  4.592
  50 GAACATGTGTGGCATTGTGTATA           21 23  0 39.13 58.360  6.00  4.00  4.640
  51 TTGTGCATATACATGTGTGTTGTG         116 24  0 37.50 59.345  6.00  2.00  4.655
  52 ATGGATGTAGCTTCTTGACTGTGT         141 24  0 41.67 59.238  4.00  1.00  4.762
  53 TTAAACATGTGTGGTATTGTGCAT         100 24  0 33.33 59.233  6.00  2.00  4.767
  54 GAACATGTGTGGCATTGTGTATAC          21 24  0 41.67 59.208  6.00  6.00  4.792
  55 CTTGTGGGTGTGTCTGTTAAAC            84 22  0 45.45 57.176  5.00  5.00  4.824
  56 TAGCTTCTTGACTGTGTGTTGTG          148 23  0 43.48 58.160  4.00  0.00  4.840
  57 TGTAGCTTCTTGACTGTGTGTTG          146 23  0 43.48 58.160  4.00  0.00  4.840
  58 TGTGTTGTGTATGGATGTAGCTTC         131 24  0 41.67 59.091  4.00  4.00  4.909
  59 TAGCTTCTTGACTGTGTGTTGTGT         148 24  0 41.67 59.030  4.00  0.00  4.970
  60 GTAGCTTCTTGACTGTGTGTTGTG         147 24  0 45.83 59.030  4.00  0.00  4.970
  61 TGTAGCTTCTTGACTGTGTGTTGT         146 24  0 41.67 59.030  4.00  0.00  4.970
  62 TGTGTCTGTTAAACATGTGTGG            92 22  0 40.91 57.024  7.00  2.00  4.976
  63 TGTGTTGTGTATGGATGTAGCTTCT        131 25  0 40.00 60.002  4.00  2.00  5.002
  64 GTTAAACATGTGTGGTATTGTGCAT         99 25  0 36.00 59.991  6.00  2.00  5.009
  65 TGTGTCTGTTAAACATGTGTGGT           92 23  0 39.13 57.983  7.00  0.00  5.017
  66 GTGTGTCTGTTAAACATGTGTGG           91 23  0 43.48 57.983  7.00  2.00  5.017
  67 GGTGTGTCTGTTAAACATGTGTG           90 23  0 43.48 57.983  7.00  4.00  5.017
  68 TGTGCATATACATGTGTGTTGTG          117 23  0 39.13 57.923  6.00  2.00  5.077
  69 AAACATGTGTGGTATTGTGCATA          102 23  0 34.78 57.903  6.00  4.00  5.097
  70 TAAACATGTGTGGTATTGTGCAT          101 23  0 34.78 57.903  6.00  2.00  5.097
  71 GTGTGTTGTGTATGGATGTAGCTTC        130 25  0 44.00 59.880  4.00  4.00  5.120
  72 GTGTGTCTGTTAAACATGTGTGGT          91 24  0 41.67 58.868  7.00  0.00  5.132
  73 TTGTGCATATACATGTGTGTTGTGT        116 25  0 36.00 60.151  6.00  0.00  5.151
  74 ATGTGTGTTGTGTATGGATGTAGC         128 24  0 41.67 58.842  2.00  2.00  5.158
  75 GTAGCTTCTTGACTGTGTGTTGTGT        147 25  0 44.00 59.835  4.00  0.00  5.165
  76 TTGTGTATGGATGTAGCTTCTTGA         135 24  0 37.50 58.834  4.00  2.00  5.166
  77 TGTGCATATACATGTGTGTTGTGT         117 24  0 37.50 58.828  6.00  0.00  5.172
  78 ATGTGTGTTGTGTATGGATGTAGCT        128 25  0 40.00 59.772  4.00  4.00  5.228
  79 GTGTCTTGTGGGTGTGTCTGTTAA          80 24  0 45.83 61.270  4.00  4.00  5.270
  80 GATGTAGCTTCTTGACTGTGTGTTG        144 25  0 44.00 60.272  4.00  0.00  5.272
  81 ACATGTGTGTTGTGTATGGATGT          126 23  0 39.13 57.646  6.00  0.00  5.354
  82 ATTGTGCATATACATGTGTGTTGTG        115 25  0 36.00 59.637  6.00  2.00  5.363
  83 TTGTGTATGGATGTAGCTTCTTGAC        135 25  0 40.00 59.615  4.00  1.00  5.385
  84 GTTGTGTATGGATGTAGCTTCTTGA        134 25  0 40.00 59.615  4.00  2.00  5.385
  85 TGTTGTGTATGGATGTAGCTTCTTG        133 25  0 40.00 60.458  4.00  2.00  5.458
  86 ATGTAGCTTCTTGACTGTGTGTTG         145 24  0 41.67 58.520  4.00  0.00  5.480
  87 GGTGTGTCTGTTAAACATGTGTGG          90 24  0 45.83 61.509  7.00  2.00  5.509
  88 GGGTGTGTCTGTTAAACATGTGTG          89 24  0 45.83 61.509  7.00  4.00  5.509
  89 TGGGTGTGTCTGTTAAACATGTGT          88 24  0 41.67 61.509  7.00  6.00  5.509
  90 GTGGGTGTGTCTGTTAAACATGTG          87 24  0 45.83 61.509  7.00  4.00  5.509
  91 TGTGGGTGTGTCTGTTAAACATGT          86 24  0 41.67 61.509  7.00  6.00  5.509
  92 TATGGATGTAGCTTCTTGACTGTG         140 24  0 41.67 58.476  4.00  1.00  5.524
  93 TGTATGGATGTAGCTTCTTGACTG         138 24  0 41.67 58.476  4.00  1.00  5.524
  94 TGTGTATGGATGTAGCTTCTTGA          136 23  0 39.13 57.467  4.00  2.00  5.533
  95 CTGTTAAACATGTGTGGTATTGTGC         97 25  0 40.00 60.599  7.00  2.00  5.599
  96 TGGATGTAGCTTCTTGACTGTGTG         142 24  0 45.83 61.619  4.00  0.00  5.619
  97 AACATGTGTGGCATTGTGTATAC           22 23  0 39.13 57.373  6.00  6.00  5.627
  98 TGTGTATGGATGTAGCTTCTTGAC         136 24  0 41.67 58.339  4.00  1.00  5.661
  99 ATGTAGCTTCTTGACTGTGTGTTGT        145 25  0 40.00 59.333  4.00  0.00  5.667
 100 TGGTATTGTGCATATACATGTGTG         111 24  0 37.50 58.315  6.00  4.00  5.685
 101 TGTGGTATTGTGCATATACATGTG         109 24  0 37.50 58.315  6.00  4.00  5.685
 102 TGTGTGGTATTGTGCATATACATG         107 24  0 37.50 58.315  6.00  6.00  5.685
 103 CATGTGTGGTATTGTGCATATACA         105 24  0 37.50 58.315  6.00  6.00  5.685
 104 TATGGATGTAGCTTCTTGACTGTGT        140 25  0 40.00 59.274  4.00  1.00  5.726
 105 GTATGGATGTAGCTTCTTGACTGTG        139 25  0 44.00 59.274  4.00  1.00  5.726
 106 TGTATGGATGTAGCTTCTTGACTGT        138 25  0 40.00 59.274  4.00  3.00  5.726
 107 GTGTATGGATGTAGCTTCTTGACTG        137 25  0 44.00 59.274  4.00  1.00  5.726
 108 TGTGTATGGATGTAGCTTCTTGACT        136 25  0 40.00 59.274  4.00  1.00  5.726
 109 AGCTTCTTGACTGTGTGTTGTGTG         149 24  0 45.83 61.730  4.00  0.00  5.730
 110 TTAAACATGTGTGGTATTGTGCATA        100 25  0 32.00 59.268  6.00  4.00  5.732
 111 TCTTGTGGGTGTGTCTGTTAAACA          83 24  0 41.67 61.733  7.00  7.00  5.733
 112 TGTCTTGTGGGTGTGTCTGTTAAA          81 24  0 41.67 61.733  4.00  3.00  5.733
 113 AAACATGTGTGGTATTGTGCATAT         102 24  0 33.33 58.262  6.00  4.00  5.738
 114 TGTGTGTTGTGTATGGATGTAGCTT        129 25  0 40.00 60.742  4.00  2.00  5.742
 115 TGTGTTGTGTATGGATGTAGCTT          131 23  0 39.13 57.257  4.00  2.00  5.743
 116 TGTGTCTTGTGGGTGTGTCTGTT           79 23  0 47.83 62.831  1.00  0.00  5.831
 117 GTGTGTTGTGTATGGATGTAGCTT         130 24  0 41.67 58.137  4.00  2.00  5.863
 118 GCATATACATGTGTGTTGTGTATGG        120 25  0 40.00 59.136  6.00  3.00  5.864
 119 TGGTATTGTGCATATACATGTGTGT        111 25  0 36.00 59.136  6.00  6.00  5.864
 120 GTGGTATTGTGCATATACATGTGTG        110 25  0 40.00 59.136  6.00  4.00  5.864
 121 TGTGGTATTGTGCATATACATGTGT        109 25  0 36.00 59.136  6.00  6.00  5.864
 122 GTGTGGTATTGTGCATATACATGTG        108 25  0 40.00 59.136  6.00  4.00  5.864
 123 TGTGTGGTATTGTGCATATACATGT        107 25  0 36.00 59.136  6.00  6.00  5.864
 124 ACATGTGTGGTATTGTGCATATACA        104 25  0 36.00 59.136  6.00  6.00  5.864
 125 TGTGTCTGTTAAACATGTGTGGTA          92 24  0 37.50 58.069  7.00  2.00  5.931
 126 GTTAAACATGTGTGGTATTGTGC           99 23  0 39.13 57.060  6.00  2.00  5.940
 127 GGATGTAGCTTCTTGACTGTGTGTT        143 25  0 44.00 60.962  4.00  0.00  5.962
 128 TTGTGTATGGATGTAGCTTCTTG          135 23  0 39.13 57.036  4.00  2.00  5.964
 129 TTGTGGGTGTGTCTGTTAAACATG          85 24  0 41.67 61.967  7.00  5.00  5.967
 130 GTTAAACATGTGTGGTATTGTGCATA        99 26  0 34.62 60.001  6.00  4.00  6.001
 131 TAAACATGTGTGGTATTGTGCATA         101 24  0 33.33 57.988  6.00  4.00  6.012
 132 GTATGGATGTAGCTTCTTGACTGTGT       139 26  0 42.31 60.018  4.00  1.00  6.018
 133 GTGTATGGATGTAGCTTCTTGACTGT       137 26  0 42.31 60.018  4.00  3.00  6.018
 134 GTGTGTCTGTTAAACATGTGTGGTA         91 25  0 40.00 58.919  7.00  2.00  6.081
 135 TCTGTTAAACATGTGTGGTATTGTG         96 25  0 36.00 58.912  7.00  0.00  6.088
 136 TGTCTGTTAAACATGTGTGGTATTG         94 25  0 36.00 58.912  7.00  0.00  6.088
 137 GTTGTGTATGGATGTAGCTTCTTG         134 24  0 41.67 57.904  4.00  2.00  6.096
 138 TGTTGTGTATGGATGTAGCTTCTT         133 24  0 37.50 57.904  4.00  4.00  6.096
 139 GTGGTATTGTGCATATACATGTGTGT       110 26  0 38.46 59.900  6.00  6.00  6.100
 140 GTGTGGTATTGTGCATATACATGTGT       108 26  0 38.46 59.900  6.00  6.00  6.100
 141 CATGTGTGTTGTGTATGGATGTAG         127 24  0 41.67 57.896  4.00  0.00  6.104
 142 TGTGCATATACATGTGTGTTGTGTA        117 25  0 36.00 58.882  6.00  2.00  6.118
 143 TTGTGCATATACATGTGTGTTGTGTA       116 26  0 34.62 60.156  6.00  2.00  6.156
 144 ACATGTGTGTTGTGTATGGATGTAG        126 25  0 40.00 58.761  6.00  0.00  6.239
 145 ACATGTGTGTTGTGTATGGATGTA         126 24  0 37.50 57.747  6.00  2.00  6.253
 146 TACATGTGTGTTGTGTATGGATGT         125 24  0 37.50 57.747  6.00  0.00  6.253
 147 GTGTTGTGTATGGATGTAGCTTCTT        132 25  0 40.00 58.712  4.00  4.00  6.288
 148 GTCTGTTAAACATGTGTGGTATTGTG        95 26  0 38.46 59.680  7.00  0.00  6.320
 149 TGTCTGTTAAACATGTGTGGTATTGT        94 26  0 34.62 59.680  7.00  0.00  6.320
 150 GTGTCTGTTAAACATGTGTGGTATTG        93 26  0 38.46 59.680  7.00  0.00  6.320
 151 TGTGTCTGTTAAACATGTGTGGTATT        92 26  0 34.62 59.680  7.00  1.00  6.320
 152 TATTGTGCATATACATGTGTGTTGTG       114 26  0 34.62 59.659  6.00  2.00  6.341
 153 GTTGTGTATGGATGTAGCTTCTTGAC       134 26  0 42.31 60.343  4.00  1.00  6.343
 154 GGTATTGTGCATATACATGTGTGTTG       112 26  0 38.46 60.346  6.00  4.00  6.346
 155 TGGTATTGTGCATATACATGTGTGTT       111 26  0 34.62 60.346  6.00  4.00  6.346
 156 AACATGTGTGGTATTGTGCATATACA       103 26  0 34.62 60.346  6.00  6.00  6.346
 157 ATGTGTGGTATTGTGCATATACATG        106 25  0 36.00 58.650  6.00  6.00  6.350
 158 CATGTGTGGTATTGTGCATATACAT        105 25  0 36.00 58.650  6.00  4.00  6.350
 159 GATGTAGCTTCTTGACTGTGTGTT         144 24  0 41.67 57.626  4.00  0.00  6.374
 160 ATTGTGCATATACATGTGTGTTGTGT       115 26  0 34.62 60.393  6.00  0.00  6.393
 161 TTGTGTATGGATGTAGCTTCTTGACT       135 26  0 38.46 60.455  4.00  1.00  6.455
 162 TTAAACATGTGTGGTATTGTGCATAT       100 26  0 30.77 59.536  6.00  4.00  6.464
 163 CATGTGTGTTGTGTATGGATGTAGC        127 25  0 44.00 61.472  4.00  2.00  6.472
 164 TGTGTCTGTTAAACATGTGTGGTAT         92 25  0 36.00 58.424  7.00  2.00  6.576
 165 ATGTGTGGTATTGTGCATATACATGT       106 26  0 34.62 59.420  6.00  6.00  6.580
 166 ACATGTGTGGTATTGTGCATATACAT       104 26  0 34.62 59.420  6.00  4.00  6.580
 167 GTGTTGTGTATGGATGTAGCTTCT         132 24  0 41.67 57.400  4.00  2.00  6.600
 168 TGCATATACATGTGTGTTGTGTATG        119 25  0 36.00 58.378  6.00  5.00  6.622
 169 AAACATGTGTGGTATTGTGCATATA        102 25  0 32.00 58.331  6.00  4.00  6.669
 170 TAAACATGTGTGGTATTGTGCATAT        101 25  0 32.00 58.331  6.00  4.00  6.669
 171 TAGCTTCTTGACTGTGTGTTGTGTG        148 25  0 44.00 61.678  4.00  0.00  6.678
 172 TGTAGCTTCTTGACTGTGTGTTGTG        146 25  0 44.00 61.678  4.00  0.00  6.678
 173 GTGTGTTGTGTATGGATGTAGCTTCT       130 26  0 42.31 60.727  4.00  2.00  6.727
 174 TGTGTCTTGTGGGTGTGTCTGTTA          79 24  0 45.83 62.734  2.00  2.00  6.734
 175 ATACATGTGTGTTGTGTATGGATG         124 24  0 37.50 57.241  6.00  0.00  6.759
 176 GTGTGTCTGTTAAACATGTGTGGTAT        91 26  0 38.46 59.220  7.00  2.00  6.780
 177 ATGGATGTAGCTTCTTGACTGTGTG        141 25  0 44.00 61.791  4.00  0.00  6.791
 178 GAACATGTGTGGCATTGTGTATACA         21 25  0 40.00 61.810  8.00  8.00  6.810
 179 GTGCATATACATGTGTGTTGTGTATG       118 26  0 38.46 59.190  6.00  5.00  6.810
 180 TGTGCATATACATGTGTGTTGTGTAT       117 26  0 34.62 59.190  6.00  3.00  6.810
 181 GCATATACATGTGTGTTGTGTATGGA       120 26  0 38.46 60.811  6.00  1.00  6.811
 182 CTGTTAAACATGTGTGGTATTGTG          97 24  0 37.50 57.140  7.00  0.00  6.860
 183 ATACATGTGTGTTGTGTATGGATGT        124 25  0 36.00 58.124  6.00  0.00  6.876
 184 TCTTGTGGGTGTGTCTGTTAAACAT         83 25  0 40.00 61.898  7.00  5.00  6.898
 185 AAACATGTGTGGTATTGTGCATATAC       102 26  0 34.62 59.095  6.00  6.00  6.905
 186 ATGTGTGTTGTGTATGGATGTAGCTT       128 26  0 38.46 60.948  4.00  2.00  6.948
 187 AACATGTGTGGTATTGTGCATATA         103 24  0 33.33 57.002  6.00  4.00  6.998
 188 GATGTAGCTTCTTGACTGTGTGTTGT       144 26  0 42.31 61.001  4.00  0.00  7.001
 189 CATGTGTGGTATTGTGCATATACATG       105 26  0 38.46 61.147  6.00  6.00  7.147
 190 GGTATTGTGCATATACATGTGTGTT        112 25  0 36.00 57.851  6.00  4.00  7.149
 191 AACATGTGTGGTATTGTGCATATAC        103 25  0 36.00 57.851  6.00  6.00  7.149
 192 GTGTTGTGTATGGATGTAGCTTCTTG       132 26  0 42.31 61.157  4.00  2.00  7.157
 193 TGTGTTGTGTATGGATGTAGCTTCTT       131 26  0 38.46 61.157  4.00  4.00  7.157
 194 TACATGTGTGTTGTGTATGGATGTA        125 25  0 36.00 57.841  6.00  2.00  7.159
 195 TACATGTGTGTTGTGTATGGATGTAG       125 26  0 38.46 58.815  6.00  0.00  7.185
 196 GGTGTGTCTGTTAAACATGTGTGGT         90 25  0 44.00 62.217  7.00  0.00  7.217
 197 GTGGGTGTGTCTGTTAAACATGTGT         87 25  0 44.00 62.217  7.00  6.00  7.217
 198 GTTAAACATGTGTGGTATTGTGCATAT       99 27  0 33.33 60.227  6.00  4.00  7.227
 199 CATATACATGTGTGTTGTGTATGGATG      121 27  0 37.04 60.230  6.00  0.00  7.230
 200 TGTTAAACATGTGTGGTATTGTGCA         98 25  0 36.00 62.264  7.00  4.00  7.264
 201 TGGATGTAGCTTCTTGACTGTGTGT        142 25  0 44.00 62.322  4.00  0.00  7.322
 202 TTGTGCATATACATGTGTGTTGTGTAT      116 27  0 33.33 60.389  6.00  3.00  7.389
 203 ATTGTGCATATACATGTGTGTTGTGTA      115 27  0 33.33 60.389  6.00  2.00  7.389
 204 TATTGTGCATATACATGTGTGTTGTGT      114 27  0 33.33 60.389  6.00  0.00  7.389
 205 GTATTGTGCATATACATGTGTGTTGTG      113 27  0 37.04 60.389  6.00  2.00  7.389
 206 GTGTCTGTTAAACATGTGTGGTATTGT       93 27  0 37.04 60.396  7.00  0.00  7.396
 207 GTGTGTCTGTTAAACATGTGTGGTATT       91 27  0 37.04 60.396  7.00  1.00  7.396
 208 TGTTGTGTATAAATGTTGTGTCTTCA        52 26  0 30.77 58.596  4.00  1.00  7.404
 209 GTCTTGTGGGTGTGTCTGTTAAACA         82 25  0 44.00 62.427  7.00  7.00  7.427
 210 TGTCTTGTGGGTGTGTCTGTTAAAC         81 25  0 44.00 62.427  5.00  5.00  7.427
 211 GTGTCTTGTGGGTGTGTCTGTTAAA         80 25  0 44.00 62.427  4.00  3.00  7.427
 212 TTAAACATGTGTGGTATTGTGCATATA      100 27  0 29.63 59.560  6.00  4.00  7.440
 213 AGCTTCTTGACTGTGTGTTGTGTGT        149 25  0 44.00 62.443  4.00  0.00  7.443
 214 AACATGTGTGGTATTGTGCATATACAT      103 27  0 33.33 60.562  6.00  4.00  7.562
 215 TAAACATGTGTGGTATTGTGCATATA       101 26  0 30.77 58.395  6.00  4.00  7.605
 216 GTGTTGTGTATAAATGTTGTGTCTTCA       51 27  0 33.33 59.358  4.00  1.00  7.642
 217 TGTGTTGTGTATAAATGTTGTGTCTTC       50 27  0 33.33 59.358  4.00  0.00  7.642
 218 TTGTGGGTGTGTCTGTTAAACATGT         85 25  0 40.00 62.648  7.00  6.00  7.648
 219 TATACATGTGTGTTGTGTATGGATG        123 25  0 36.00 57.352  6.00  0.00  7.648
 220 CATATACATGTGTGTTGTGTATGGA        121 25  0 36.00 57.352  6.00  0.00  7.648
 221 TGCATATACATGTGTGTTGTGTATGG       119 26  0 38.46 61.654  6.00  3.00  7.654
 222 TGTGGTATTGTGCATATACATGTGTG       109 26  0 38.46 61.654  6.00  4.00  7.654
 223 TGTGTGGTATTGTGCATATACATGTG       107 26  0 38.46 61.654  6.00  4.00  7.654
 224 TATGGATGTAGCTTCTTGACTGTGTG       140 26  0 42.31 61.740  4.00  0.00  7.740
 225 TGTATGGATGTAGCTTCTTGACTGTG       138 26  0 42.31 61.740  4.00  1.00  7.740
 226 TGTGTATGGATGTAGCTTCTTGACTG       136 26  0 42.31 61.740  4.00  1.00  7.740
 227 CTTGTGGGTGTGTCTGTTAAACATG         84 25  0 44.00 62.749  7.00  5.00  7.749
 228 ATACATGTGTGTTGTGTATGGATGTA       124 26  0 34.62 58.200  6.00  2.00  7.800
 229 TATACATGTGTGTTGTGTATGGATGT       123 26  0 34.62 58.200  6.00  0.00  7.800
 230 ATGTAGCTTCTTGACTGTGTGTTGTG       145 26  0 42.31 61.844  4.00  0.00  7.844
 231 GTCTGTTAAACATGTGTGGTATTGT         95 25  0 36.00 57.143  7.00  0.00  7.857
 232 GTGTCTGTTAAACATGTGTGGTATT         93 25  0 36.00 57.143  7.00  1.00  7.857
 233 TAAACATGTGTGGTATTGTGCATATAC      101 27  0 33.33 59.133  6.00  6.00  7.867
 234 ATACATGTGTGTTGTGTATGGATGTAG      124 27  0 37.04 59.113  6.00  0.00  7.887
 235 TATTGTGCATATACATGTGTGTTGT        114 25  0 32.00 57.073  6.00  2.00  7.927
 236 GTATTGTGCATATACATGTGTGTTG        113 25  0 36.00 57.073  6.00  4.00  7.927
 237 GCATATACATGTGTGTTGTGTATGGAT      120 27  0 37.04 61.010  6.00  2.00  8.010
 238 GGTATTGTGCATATACATGTGTGTTGT      112 27  0 37.04 61.034  6.00  2.00  8.034
 239 GTGGTATTGTGCATATACATGTGTGTT      110 27  0 37.04 61.034  6.00  4.00  8.034
 240 TGTTGTGTATGGATGTAGCTTCTTGA       133 26  0 38.46 62.056  4.00  2.00  8.056
 241 GTATTGTGCATATACATGTGTGTTGT       113 26  0 34.62 57.913  6.00  2.00  8.087
 242 GTTGTGTATGGATGTAGCTTCTTGACT      134 27  0 40.74 61.126  4.00  1.00  8.126
 243 GGTGTGTCTGTTAAACATGTGTGGTA        90 26  0 42.31 62.150  7.00  2.00  8.150
 244 ACATGTGTGTTGTGTATGGATGTAGC       126 26  0 42.31 62.163  6.00  2.00  8.163
 245 TCTGTTAAACATGTGTGGTATTGTGC        96 26  0 38.46 62.185  7.00  2.00  8.185
 246 CATGTGTGTTGTGTATGGATGTAGCT       127 26  0 42.31 62.266  4.00  4.00  8.266
 247 ATATACATGTGTGTTGTGTATGGATG       122 26  0 34.62 57.730  6.00  0.00  8.270
 248 CATATACATGTGTGTTGTGTATGGAT       121 26  0 34.62 57.730  6.00  2.00  8.270
 249 TGTGTTGTGTATAAATGTTGTGTCTT        50 26  0 30.77 57.700  4.00  0.00  8.300
 250 TAGCTTCTTGACTGTGTGTTGTGTGT       148 26  0 42.31 62.367  4.00  0.00  8.367
 251 GTAGCTTCTTGACTGTGTGTTGTGTG       147 26  0 46.15 62.367  4.00  0.00  8.367
 252 TGTAGCTTCTTGACTGTGTGTTGTGT       146 26  0 42.31 62.367  4.00  0.00  8.367
 253 TGTGTGTTGTGTATGGATGTAGCTTC       129 26  0 42.31 62.368  4.00  4.00  8.368
 254 TGTTAAACATGTGTGGTATTGTGCAT        98 26  0 34.62 62.397  7.00  2.00  8.397
 255 AAACATGTGTGGTATTGTGCATATACA      102 27  0 33.33 61.445  6.00  6.00  8.445
 256 ATGGATGTAGCTTCTTGACTGTGTGT       141 26  0 42.31 62.454  4.00  0.00  8.454
 257 ATATACATGTGTGTTGTGTATGGATGT      122 27  0 33.33 58.526  6.00  0.00  8.474
 258 GTCTTGTGGGTGTGTCTGTTAAACAT        82 26  0 42.31 62.553  7.00  5.00  8.553
 259 TGTGCATATACATGTGTGTTGTGTATG      117 27  0 37.04 61.688  6.00  5.00  8.688
 260 TATACATGTGTGTTGTGTATGGATGTA      123 27  0 33.33 58.271  6.00  2.00  8.729
 261 GTGTGTTGTGTATGGATGTAGCTTCTT      130 27  0 40.74 61.811  4.00  4.00  8.811
 262 ATGTGTGGTATTGTGCATATACATGTG      106 27  0 37.04 61.814  6.00  4.00  8.814
 263 CATGTGTGGTATTGTGCATATACATGT      105 27  0 37.04 61.814  6.00  6.00  8.814
 264 ACATGTGTGGTATTGTGCATATACATG      104 27  0 37.04 61.814  6.00  6.00  8.814
 265 ATGTGTTGTGTATAAATGTTGTGTCTT       49 27  0 29.63 58.041  4.00  0.00  8.959
 266 TGTCTGTTAAACATGTGTGGTATTGTG       94 27  0 37.04 62.089  7.00  0.00  9.089
 267 TGTGTCTGTTAAACATGTGTGGTATTG       92 27  0 37.04 62.089  7.00  0.00  9.089
 268 TACATGTGTGTTGTGTATGGATGTAGC      125 27  0 40.74 62.100  6.00  2.00  9.100
 269 GGTGTGTCTGTTAAACATGTGTGGTAT       90 27  0 40.74 62.286  7.00  2.00  9.286
 270 GTGCATATACATGTGTGTTGTGTATGG      118 27  0 40.74 62.312  6.00  3.00  9.312
 271 TGTGGTATTGTGCATATACATGTGTGT      109 27  0 37.04 62.312  6.00  6.00  9.312
 272 GTGTGGTATTGTGCATATACATGTGTG      108 27  0 40.74 62.312  6.00  4.00  9.312
 273 TGTGTGGTATTGTGCATATACATGTGT      107 27  0 37.04 62.312  6.00  6.00  9.312
 274 TGTTAAACATGTGTGGTATTGTGCATA       98 27  0 33.33 62.329  7.00  4.00  9.329
 275 TATGGATGTAGCTTCTTGACTGTGTGT      140 27  0 40.74 62.383  4.00  0.00  9.383
 276 GTATGGATGTAGCTTCTTGACTGTGTG      139 27  0 44.44 62.383  4.00  0.00  9.383
 277 TGTATGGATGTAGCTTCTTGACTGTGT      138 27  0 40.74 62.383  4.00  1.00  9.383
 278 GTGTATGGATGTAGCTTCTTGACTGTG      137 27  0 44.44 62.383  4.00  1.00  9.383
 279 TGTGTATGGATGTAGCTTCTTGACTGT      136 27  0 40.74 62.383  4.00  3.00  9.383
 280 ATGTGTGTTGTGTATGGATGTAGCTTC      128 27  0 40.74 62.494  4.00  4.00  9.494
 281 ATGTAGCTTCTTGACTGTGTGTTGTGT      145 27  0 40.74 62.495  4.00  0.00  9.495
 282 TGTTGTGTATGGATGTAGCTTCTTGAC      133 27  0 40.74 62.685  4.00  1.00  9.685
 283 GTGTTGTGTATGGATGTAGCTTCTTGA      132 27  0 40.74 62.685  4.00  2.00  9.685
 284 TGGTATTGTGCATATACATGTGTGTTG      111 27  0 37.04 62.716  6.00  4.00  9.716
 285 TTGTGTATGGATGTAGCTTCTTGACTG      135 27  0 40.74 62.778  4.00  1.00  9.778
 286 GTCTGTTAAACATGTGTGGTATTGTGC       95 27  0 40.74 62.806  7.00  2.00  9.806
 287 CATATGTGTTGTGTATAAATGTTGTGT       46 27  0 29.63 57.112  6.00  0.00  9.888
 288 ACATATGTGTTGTGTATAAATGTTGTG       45 27  0 29.63 57.112  8.00  0.00  9.888
 289 CACATATGTGTTGTGTATAAATGTTGT       44 27  0 29.63 57.112 10.00  2.00  9.888
 290 ACACATATGTGTTGTGTATAAATGTTG       43 27  0 29.63 57.112 12.00  0.00  9.888
 291 ACATGTGTGTTGTGTATGGATGTAGCT      126 27  0 40.74 62.902  6.00  4.00  9.902


c     ****************************************************************
c     *                                                              *
c     *                  subroutine dimrot                           *
c     *                                                              *
c     *                  written by : rhd                            *
c     *                                                              *
c     *             last modified : 2/17/2018 rhd                    *
c     *                                                              *
c     *    compute the 3x3 global -> crack front local rotation      *
c     *                                                              *
c     ****************************************************************
c
      subroutine dimrot( scoord, coord_map, u, dstmap, debug, iout )
c
      use main_data, only : trn, trnmat
      use j_data, only : num_front_nodes, front_order, front_nodes,
     &                   front_coords, front_node_displ,
     &                   domain_origin, domain_type, domain_rot,
     &                   crack_plane_normal, crack_front_tangent,
     &                   tangent_vector_defined
      implicit none
c
c                     parameter declarations
c
      integer :: iout, coord_map(*), dstmap(*)
      double precision :: scoord(*), u(*)
      logical :: debug
c
c                     local declarations
c
      integer :: node, node_id, caseno, frnint, status, i, ftype,
     &           nfnode
      double precision :: nx, ny, nz, xcrack(3), tvec(3),
     &                    length, x, y, z, unode, vnode, wnode
      double precision, parameter :: zero = 0.0d0, one = 1.0d0
c
      if( debug ) then
         write(iout,*) ' '
         write(iout,*) ' >>> entered make domain rotation'
         write(iout,*) '     > no. front nodes, interpolation: ',
     &                 num_front_nodes, front_order
      end if
c
c             gather coordinates and displacements of crack-front nodes
c
      do node = 1, num_front_nodes
         node_id                  = front_nodes(node)
         front_coords(1,node)     = scoord(coord_map(node_id))
         front_coords(2,node)     = scoord(coord_map(node_id)+1)
         front_coords(3,node)     = scoord(coord_map(node_id)+2)
         front_node_displ(1,node) = u(dstmap(node_id)+0)
         front_node_displ(2,node) = u(dstmap(node_id)+1)
         front_node_displ(3,node) = u(dstmap(node_id)+2)
      end do
c
      domain_rot = zero
      nx = crack_plane_normal(1)
      ny = crack_plane_normal(2)
      nz = crack_plane_normal(3)
c
c
c             if only one node on the crack front. we have the
c             simple 2-D case. rotation matrix determined only by
c             direction cosines. global-z and crack-z are assumed
c             to coincide.
c
      if( num_front_nodes .eq. 1 ) then
        nx = crack_plane_normal(1)
        ny = crack_plane_normal(2)
        domain_rot(1,1) = ny
        domain_rot(2,1) = nx
        domain_rot(1,2) = -one * nx
        domain_rot(2,2) = ny
        domain_rot(3,3) = one
        call dimrot_coord_displ
        if( .not. debug ) return
        write(iout,9100) nx, ny, domain_rot(1,1), domain_rot(1,2),
     &                   domain_rot(1,3), domain_rot(2,1),
     &                   domain_rot(2,2), domain_rot(2,3),
     &                   domain_rot(3,1), domain_rot(3,2),
     &                   domain_rot(3,3)
        return
      end if
c
c             more than one node on front specified. we have a
c             3-D situation.
c             get the position of the front-node to be used as
c             the domain origin. for domain types 'a', 'b' and
c             'c', (types 1, 2 and 3, respectively), take the
c             domain origin as the location where the crack-front
c             advance is maximum (where the q-value equals 1.0).
c             for domain type 'd' (uniform crack advance) take the
c             domain origin as the first front node.
c
      domain_origin = 0
      caseno        = 0
c
      select case( domain_type )
       case( 1 )
         domain_origin = 1
         if( num_front_nodes.eq.2 ) caseno = 1
         if( num_front_nodes.eq.3 ) caseno = 3
         if( num_front_nodes.eq.4 ) caseno = 4
       case( 2 )
         if( num_front_nodes .eq. 3 ) then
            domain_origin = 2
            caseno        = 2
         end if
         if( num_front_nodes .eq. 5 ) then
            domain_origin = 3
            caseno        = 5
         end if
         if( num_front_nodes .eq. 6 ) then
            domain_origin = 3
            caseno        = 5
         end if
       case( 3 )
         caseno = 1
         if( num_front_nodes.eq.2 ) domain_origin = 2
         if( num_front_nodes.eq.3 ) domain_origin = 3
       case( 4 )
         domain_origin = 1
      end select
c
c             based on the number of front nodes,
c             interpolation order, and q-function type construct a
c             unit tangent vector to the front that lies in the
c             crack plane (crack-z direction). crack-y is given
c             by dir cosines of normal to crack plane. construct
c             crack-x and final 3x3 structure-to-crack rotation
c             by cross-product.
c
c             for q-function type 'd' (=4), we just use the first
c             two nodes on the front to find the tangent vector.
c             this case is for a uniform crack advance along the
c             full front.
c
c             alternatively, the user may have defined components of
c             the crack front tangent vector rather than using the
c             computed value. this feature helps, for example, when the
c             mesh has the crack front intersecting a symmetry plane
c             at other than 90-degrees. A correct user-defined tangent
c             vector restores domain independent J-values. difrtn
c             takes care of this case as well.
c
c
      frnint = front_order
      ftype  = domain_type
      nfnode = num_front_nodes
c
      if( domain_type .eq. 4 ) then
c
c             get crack front (unit) tangent vector (crack-z) using
c             first 2 nodes listed on front.
c
        call dimrott( 2, front_nodes, 1, scoord, coord_map, tvec, 1,
     &                crack_front_tangent, tangent_vector_defined,
     &                iout, debug, status )
      else
        if ( nfnode .gt. 5 ) then
           write(iout,*) '>> too many nodes on front'
           call die_abort
           stop
        end if
        if( caseno .eq. 0 ) then
           write(iout,*) '>> invalid front node list/element type'
           write(iout,*) '>> combination'
           call die_abort
           stop
        end if
        if( debug ) then
           write(iout,*) '     > rotation by dir. cosines '
           write(iout,*) '        front interpolation: ', frnint
           write(iout,*) '        domain type:         ', ftype
        end if
c
c             get crack front (unit) tangent vector (crack-z).
c
        call dimrott( num_front_nodes, front_nodes, caseno, scoord,
     &               coord_map, tvec, domain_type,
     &               crack_front_tangent, tangent_vector_defined,
     &               iout, debug, status )
      end if
      if( status .eq. 1 ) then
         write(iout,9300)
         domain_rot(1,1) = one
         domain_rot(2,2) = one
         domain_rot(3,3) = one
         return
      end if
c
c             compute crack-x unit vector from z and y. fill in
c             global-to-crack rotation matrix.
c
      xcrack(1) = ny * tvec(3)  -  nz * tvec(2)
      xcrack(2) = nz * tvec(1)  -  nx * tvec(3)
      xcrack(3) = nx * tvec(2)  -  ny * tvec(1)
c
      length          = sqrt( xcrack(1)**2 + xcrack(2)**2 +
     &                        xcrack(3)**2 )
      xcrack(1)       = xcrack(1) / length
      xcrack(2)       = xcrack(2) / length
      xcrack(3)       = xcrack(3) / length
      domain_rot(1,1) = xcrack(1)
      domain_rot(1,2) = xcrack(2)
      domain_rot(1,3) = xcrack(3)
      domain_rot(2,1) = nx
      domain_rot(2,2) = ny
      domain_rot(2,3) = nz
      domain_rot(3,1) = tvec(1)
      domain_rot(3,2) = tvec(2)
      domain_rot(3,3) = tvec(3)
c
      call dimrot_coord_displ
c
      if ( .not. debug ) return
      write(iout,9200) xcrack, nx, ny, nz, tvec,
     &                 domain_rot(1,1), domain_rot(1,2),
     &                 domain_rot(1,3), domain_rot(2,1),
     &                 domain_rot(2,2), domain_rot(2,3),
     &                 domain_rot(3,1), domain_rot(3,2),
     &                 domain_rot(3,3)
      write(iout,9006) (node,(front_coords(i,node),
     &                     i=1,3), node=1,num_front_nodes )
      write(iout,9010) (node,(front_node_displ(i,node),
     &                     i=1,3), node=1,num_front_nodes )
c
      return
c
 9006 format (' >>>  front-node coordinates in crack reference frame',
     & //,5x,'node',15x,'x',19x,'y',19x,'z',15(/,i5,3f20.6))
 9010 format (' >>>  front-node displacements in crack reference frame',
     & //,5x,'node',15x,'u',19x,'v',19x,'w',15(/,i5,3f20.6))
 9100 format('     > debug for crack rotation by 2-d dir cosines.',
     & /,    '       nx -- ', f8.4,
     & /,    '       ny -- ', f8.4,
     & /,    '       rotation matrix -- ',
     &  3(/,10x,3f20.6)// )
 9200 format('      > debug for crack rotation by 3-d dir cosines.',
     & /,    '        xcrack -- ', 3f8.4,
     & /,    '        ycrack -- ', 3f8.4,
     & /,    '        zcrack -- ', 3f8.4
     & /,    '        rotation matrix -- ',
     &  3(/,10x,3f20.6)// )
 9300 format(  ' >>>>> ERROR: domain computation of global-to-'
     &       /,'       crack system rotation failed. identity',
     &       ' matrix assumed.',// )
c
      contains
c     ========
c
      subroutine dimrot_coord_displ
      implicit none
c
c              rotate coordinates of crack-front
c              nodes to local system.
c
      do node = 1, num_front_nodes
         x = domain_rot(1,1) * front_coords(1,node)
     &     + domain_rot(1,2) * front_coords(2,node)
     &     + domain_rot(1,3) * front_coords(3,node)
         y = domain_rot(2,1) * front_coords(1,node)
     &     + domain_rot(2,2) * front_coords(2,node)
     &     + domain_rot(2,3) * front_coords(3,node)
         z = domain_rot(3,1) * front_coords(1,node)
     &     + domain_rot(3,2) * front_coords(2,node)
     &     + domain_rot(3,3) * front_coords(3,node)
         front_coords(1,node) = x
         front_coords(2,node) = y
         front_coords(3,node) = z
c
c            if necessary, transform nodal displacement values
c            from constraint-compatible coordinates to global
c            coordinates. then rotate displacements from global
c            to local coordinates
c
         node_id = front_nodes(node)
         if( trn(node_id) ) then
            call di_trans_nodvals( front_node_displ(1,node),
     &           trnmat(node_id)%mat(1,1) )
         end if
c
         unode = domain_rot(1,1) * front_node_displ(1,node)
     &         + domain_rot(1,2) * front_node_displ(2,node)
     &         + domain_rot(1,3) * front_node_displ(3,node)
         vnode = domain_rot(2,1) * front_node_displ(1,node)
     &         + domain_rot(2,2) * front_node_displ(2,node)
     &         + domain_rot(2,3) * front_node_displ(3,node)
         wnode = domain_rot(3,1) * front_node_displ(1,node)
     &         + domain_rot(3,2) * front_node_displ(2,node)
     &         + domain_rot(3,3) * front_node_displ(3,node)
         front_node_displ(1,node) = unode
         front_node_displ(2,node) = vnode
         front_node_displ(3,node) = wnode
      end do
c
      return
      end subroutine dimrot_coord_displ
c
      end subroutine dimrot
c
c     ****************************************************************
c     *                                                              *
c     *                   support routine dimrott                    *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 2/17/2018 rhd              *
c     *                                                              *
c     *        unit tangent vector to front directed along crack     *
c     *        local-Z direction                                     *
c     *                                                              *
c     ****************************************************************
c
      subroutine dimrott( nfnode, fnodes, caseno, scoord,
     &                    coord_map, tvec, fnctyp, crack_front_tangent,
     &                    tangent_vector_defined, iout, debug, status )
      implicit none
c
c               parameter declarations
c
      integer :: nfnode, fnodes(*), caseno, fnctyp, iout, status,
     &           coord_map(*)
      double precision :: scoord(*), tvec(*), crack_front_tangent(*)
      logical :: tangent_vector_defined, debug
c
c               local declarations
c
      integer :: ii, jj, coord_loc, nfn
      double precision :: dsf(4), sf(4), tvec1(3), tvec2(3),
     &                    dx, dy, dz, xsi
      double precision, parameter :: zero = 0.0d0, half = 0.5d0,
     &                               one = 1.0d0
c
c             compute or load unit tangent vector to the crack
c             front according to the situation indicated by the
c             case number or the user-defined flag.
c             for cases 2,5,6 we average two tangents
c             computed for adjacent line segments. for cases 1,3,4 we
c             compute a single tangent at start or end of line segment.
c             fnodes is list of structure nodes defining the segment(s).
c
c             tangent_vector_defined = .T. --> the user specified the
c                                              tangent vector to use.
c                                              components are in
c                                              crack_front_tangent
c                                              skip computations.
c
c
c             case no.           situation
c             --------           ---------
c                1               linear; 2-nodes on front
c                2               linear; 3-nodes on front
c                3               quadratic; 3-nodes on front
c                4               cubic; 4-nodes on front
c                5               quadratic; 5-nodes on front
c                6               cubic; 7-nodes on front
c
c             fnctyp: 1-4, used for cases 3,4 to determine if
c                     tangent is needed for first or last node
c                     on front. = 1 (first node), =3 (last node).
c
c             status: returned value = 0 (ok) = 1 (bad data)
c
      if( tangent_vector_defined ) then
        dx = crack_front_tangent(1)
        dy = crack_front_tangent(2)
        dz = crack_front_tangent(3)
        call difrts( dx, dy, dz, tvec, status )
        if ( .not. debug ) return
        write(iout,9200)  tangent_vector_defined,  caseno, fnctyp,
     &                  status, tvec(1), tvec(2), tvec(3)
      end if
c
c             case 1,3,4: 2, 3 or four nodes on front but only a single
c                         element (linear, quadratic or cubic). compute
c                         tangent at first or last node (2,3 or 4). use
c                         utility routine to get derivatives of the 1-D
c                         isoparametric shape functions.
c
c             case 2,5,6: two linear, quadratic or cubic segments
c                         connecting 3, 5 or 6 front nodes.
c                         compute average tangent at center (common)
c                         node. compute two unit tangents, average
c                         components, then restore unit length.
      select case( caseno )
c
      case( 1, 3, 4 )
      if( fnctyp .eq. 1 ) then
         xsi = -one
       elseif( fnctyp .eq. 3 ) then
         xsi = one
       else
         write(iout,9100) fnctyp
         call die_gracefully
         stop
      end if
      call di1dsfc( xsi, dsf, sf, nfnode )
      dx = zero
      dy = zero
      dz = zero
      do ii = 1, nfnode
        coord_loc  = coord_map(fnodes(ii)) - 1
        dx = dx + dsf(ii)*scoord(coord_loc+1)
        dy = dy + dsf(ii)*scoord(coord_loc+2)
        dz = dz + dsf(ii)*scoord(coord_loc+3)
      end do
      call difrts( dx, dy, dz, tvec, status )
c
      case( 2, 5, 6 )
      nfn = 2
      if( caseno .eq. 5) nfn = 3
      if( caseno .eq. 6) nfn = 4
      xsi = one
      call di1dsfc( xsi, dsf, sf, nfn )
      dx = zero
      dy = zero
      dz = zero
      do ii = 1, nfn
        coord_loc = coord_map(fnodes(ii)) - 1
        dx = dx + dsf(ii)*scoord(coord_loc+1)
        dy = dy + dsf(ii)*scoord(coord_loc+2)
        dz = dz + dsf(ii)*scoord(coord_loc+3)
      end do
      call difrts( dx, dy, dz, tvec1, status )
      if( status .eq. 1 ) return
      xsi = -one
      call di1dsfc( xsi, dsf, sf, nfn )
      dx = zero
      dy = zero
      dz = zero
      jj = nfn - 1
      do ii = 1, nfn
        coord_loc = coord_map(fnodes(jj+ii)) - 1
        dx = dx + dsf(ii)*scoord(coord_loc+1)
        dy = dy + dsf(ii)*scoord(coord_loc+2)
        dz = dz + dsf(ii)*scoord(coord_loc+3)
      end do
      call difrts( dx, dy, dz, tvec2, status )
      if( status .eq. 1 ) return
      dx = (tvec1(1) + tvec2(1)) * half
      dy = (tvec1(2) + tvec2(2)) * half
      dz = (tvec1(3) + tvec2(3)) * half
      call difrts( dx, dy, dz, tvec, status )
c
      end select
c
c             all done.
c
      if ( .not. debug ) return
      write(iout,9200)  tangent_vector_defined,  caseno, fnctyp,
     &                  status, tvec(1), tvec(2), tvec(3)
      return
c
 9100 format('>>>>> SYSTEM ERROR:in difrtn. fnctyp has illegal',
     &  /,   '                   value: ',i10,
     &  /,   '                   job terminated.')
 9200 format('      > leaving dimrott...',
     & /,20x,'tangent_vector_defined: ',l1,
     & /,20x,'caseno:       ',i10,
     & /,20x,'domain_type:  ',i10,
     & /,20x,'status:       ',i10,
     & /,20x,'tangent vec:  ',3f10.6)
c
      end
c *******************************************************************
c *                                                                 *
c *   support routine: called by difrts                             *
c *                                                                 *
c *******************************************************************
c
c
      subroutine difrts( dx, dy, dz, tvec, status )
      implicit none
c
      integer :: status
      double precision :: dx, dy, dz, tvec(3)
c
      double precision :: length
c
      length = sqrt( dx*dx + dy*dy + dz*dz )
      status = 1
      if( length .lt. 1.0d-07 ) return
      tvec(1) = dx / length
      tvec(2) = dy / length
      tvec(3) = dz / length
      status = 0
c
      return
      end
c *******************************************************************
c *                                                                 *
c *   subroutine di1dsfc ---- calculates shape function values and  *
c *                           derivatives for 1-dimension           *
c *                                                                 *
c *******************************************************************
c
      subroutine di1dsfc( xsi, dsf, sf, nlnode )
c
c              parameter declarations
c
      implicit none
c
      integer :: nlnode
      double precision  :: xsi, dsf(*), sf(*)
c
c              local declarations
c
      double precision :: xsisqr
      double precision, parameter :: half = 0.5d0, one = 1.0d0,
     &                               two = 2.0d0
c
      select case( nlnode )
c
        case(1, 2)  ! linear
        sf(1)  = half * ( one - xsi )
        sf(2)  = half * ( one + xsi )
        dsf(1) = -half
        dsf(2) =  half
c
        case( 3 )  ! quadratic
        xsisqr = xsi * xsi
        sf(1)  = half * ( xsisqr - xsi )
        sf(2)  = one - xsisqr
        sf(3)  = half * ( xsisqr + xsi )
        dsf(1) = xsi - half
        dsf(2) = -two*xsi
        dsf(3) = xsi + half
c
      end select
c
      return
      end


C   IMSL ROUTINE NAME   - ZSPWG                                         ZSPX0010
C                                                                       ZSPX0020
C-----------------------------------------------------------------------ZSPX0030
C                                                                       ZSPX0040
C   COMPUTER            - VAX/SINGLE                                    ZSPX0050
C                                                                       ZSPX0060
C   LATEST REVISION     - JUNE 1, 1982                                  ZSPX0070
C                                                                       ZSPX0080
C   PURPOSE             - NUCLEUS CALLED ONLY BY IMSL SUBROUTINE ZSPOW  ZSPX0090
C                                                                       ZSPX0100
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32                         ZSPX0110
C                       - SINGLE/H36,H48,H60                            ZSPX0120
C                                                                       ZSPX0130
C   REQD. IMSL ROUTINES - SINGLE/VBLA=SNRM2                             ZSPX0140
C                       - DOUBLE/VBLA=DNRM2                             ZSPX0150
C                                                                       ZSPX0160
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND           ZSPX0170
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL      ZSPX0180
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP  ZSPX0190
C                                                                       ZSPX0200
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.       ZSPX0210
C                                                                       ZSPX0220
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN ZSPX0230
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,    ZSPX0240
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.        ZSPX0250
C                                                                       ZSPX0260
C-----------------------------------------------------------------------ZSPX0270
C                                                                       ZSPX0280
      SUBROUTINE ZSPWG (M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA)     ZSPX0290
C                                  SPECIFICATIONS FOR ARGUMENTS         ZSPX0300
      INTEGER            M,N,LDA,LIPVT,IPVT(LIPVT)                      ZSPX0310
      REAL               A(LDA,N),RDIAG(N),ACNORM(N),WA(N)              ZSPX0320
      LOGICAL            PIVOT                                          ZSPX0330
C                                  SPECIFICATIONS FOR LOCAL VARIABLES   ZSPX0340
      INTEGER            I,JP1,J,KMAX,K,MINMN                           ZSPX0350
      REAL               AJNORM,EPSMCH,ONE,P05,SPMPAR,SUM,TEMP,ZERO     ZSPX0360
      REAL               SNRM2                                          ZSPX0370
      DATA               SPMPAR /1.1921E-07/                            ZSPX0380
c      DATA	             SPMPAR /2.2204E-16/
      DATA               ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/              ZSPX0390
C                                  EPSMCH IS THE MACHINE PRECISION.     ZSPX0400
C                                  FIRST EXECUTABLE STATEMENT           ZSPX0410
      EPSMCH = SPMPAR                                                   ZSPX0420
C                                  COMPUTE THE INITIAL COLUMN NORMS AND ZSPX0430
C                                  INITIALIZE SEVERAL ARRAYS.           ZSPX0440
      DO 5 J=1,N                                                        ZSPX0450
         ACNORM(J) = SNRM2(M,A(1,J),1)                                  ZSPX0460
         RDIAG(J) = ACNORM(J)                                           ZSPX0470
         WA(J) = RDIAG(J)                                               ZSPX0480
         IF (PIVOT) IPVT(J) = J                                         ZSPX0490
    5 CONTINUE                                                          ZSPX0500
C                                  REDUCE A TO R WITH HOUSEHOLDER       ZSPX0510
C                                  TRANSFORMATIONS.                     ZSPX0520
      MINMN = MIN0(M,N)                                                 ZSPX0530
      DO 55 J=1,MINMN                                                   ZSPX0540
         IF (.NOT.PIVOT) GO TO 20                                       ZSPX0550
C                                  BRING THE COLUMN OF LARGEST NORM INTOZSPX0560
C                                  THE PIVOT POSITION.                  ZSPX0570
         KMAX = J                                                       ZSPX0580
         DO 10 K=J,N                                                    ZSPX0590
            IF (RDIAG(K).GT.RDIAG(KMAX)) KMAX = K                       ZSPX0600
   10    CONTINUE                                                       ZSPX0610
         IF (KMAX.EQ.J) GO TO 20                                        ZSPX0620
         DO 15 I=1,M                                                    ZSPX0630
            TEMP = A(I,J)                                               ZSPX0640
            A(I,J) = A(I,KMAX)                                          ZSPX0650
            A(I,KMAX) = TEMP                                            ZSPX0660
   15    CONTINUE                                                       ZSPX0670
         RDIAG(KMAX) = RDIAG(J)                                         ZSPX0680
         WA(KMAX) = WA(J)                                               ZSPX0690
         K = IPVT(J)                                                    ZSPX0700
         IPVT(J) = IPVT(KMAX)                                           ZSPX0710
         IPVT(KMAX) = K                                                 ZSPX0720
   20    CONTINUE                                                       ZSPX0730
C                                  COMPUTE THE HOUSEHOLDER              ZSPX0740
C                                  TRANSFORMATION TO REDUCE THE J-TH    ZSPX0750
C                                  COLUMN OF A TO A MULTIPLE OF THE J-THZSPX0760
C                                  UNIT VECTOR.                         ZSPX0770
         AJNORM = SNRM2(M-J+1,A(J,J),1)                                 ZSPX0780
         IF (AJNORM.EQ.ZERO) GO TO 50                                   ZSPX0790
         IF (A(J,J).LT.ZERO) AJNORM = -AJNORM                           ZSPX0800
         DO 25 I=J,M                                                    ZSPX0810
            A(I,J) = A(I,J)/AJNORM                                      ZSPX0820
   25    CONTINUE                                                       ZSPX0830
         A(J,J) = A(J,J)+ONE                                            ZSPX0840
C                                  APPLY THE TRANSFORMATION TO THE      ZSPX0850
C                                  REMAINING COLUMNS AND UPDATE THE     ZSPX0860
C                                  NORMS.                               ZSPX0870
         JP1 = J+1                                                      ZSPX0880
         IF (N.LT.JP1) GO TO 50                                         ZSPX0890
         DO 45 K=JP1,N                                                  ZSPX0900
            SUM = ZERO                                                  ZSPX0910
            DO 30 I=J,M                                                 ZSPX0920
               SUM = SUM+A(I,J)*A(I,K)                                  ZSPX0930
   30       CONTINUE                                                    ZSPX0940
            TEMP = SUM/A(J,J)                                           ZSPX0950
            DO 35 I=J,M                                                 ZSPX0960
               A(I,K) = A(I,K)-TEMP*A(I,J)                              ZSPX0970
   35       CONTINUE                                                    ZSPX0980
            IF (.NOT.PIVOT .OR. RDIAG(K).EQ.ZERO) GO TO 40              ZSPX0990
            TEMP = A(J,K)/RDIAG(K)                                      ZSPX1000
            RDIAG(K) = RDIAG(K)*SQRT(AMAX1(ZERO,ONE-TEMP**2))           ZSPX1010
            IF (P05*(RDIAG(K)/WA(K))**2.GT.EPSMCH) GO TO 40             ZSPX1020
            RDIAG(K) = SNRM2(M-J,A(JP1,K),1)                            ZSPX1030
            WA(K) = RDIAG(K)                                            ZSPX1040
   40       CONTINUE                                                    ZSPX1050
   45    CONTINUE                                                       ZSPX1060
   50    CONTINUE                                                       ZSPX1070
         RDIAG(J) = -AJNORM                                             ZSPX1080
   55 CONTINUE                                                          ZSPX1090
      RETURN                                                            ZSPX1100
      END                                                               ZSPX1110


module adcirc_interface
  use amuse_adcirc
  implicit none

contains

function set_rootdir(rootdir_) result(ret)
  integer :: ret
  character(256) :: rootdir_
  ROOTDIR=rootdir_
  ret=0
end function
function get_rootdir(rootdir_) result(ret)
  integer :: ret
  character(256) :: rootdir_
  rootdir_=ROOTDIR
  ret=0
end function

function initialize_code() result(ret)
  integer :: ret
  ROOTDIR='.'
  ret=0
end function

function evolve_model(tend) result(ret)
  integer :: i,ret
  real(8) :: tend
  do while((ITIME_BGN-1)*DTDP+STATIM*86400.D0<tend-DTDP/2)
    call ADCIRC_Run(1)
  enddo
  DETA_DT(1:NP)=(ETA2(1:NP)-ETA1(1:NP))/DTDP
  if(.not.use_interface_elevation_boundary) ESBIN(1:NETA)=ETA2(NBD(1:NETA))
  if(.not.use_interface_flow_boundary) then
    FBQX(1:NVEL)=VV2(NBV(1:NVEL))*(DP(NBV(1:NVEL))+IFNLFA*ETA2(NBV(1:NVEL)))
    FBQY(1:NVEL)=UU2(NBV(1:NVEL))*(DP(NBV(1:NVEL))+IFNLFA*ETA2(NBV(1:NVEL)))
  else
    do i=1, NVEL
      if(LBCODEI(i).NE.2.AND.LBCODEI(i).NE.12.AND.LBCODEI(i).NE.22) then
        FBQX(i)=VV2(NBV(i))*(DP(NBV(i))+IFNLFA*ETA2(NBV(i)))
        FBQY(i)=UU2(NBV(i))*(DP(NBV(i))+IFNLFA*ETA2(NBV(i)))
      endif
    enddo
  endif
  if(.not.use_interface_met_forcing) then
    WSX(1:NP)=WSX2(1:NP)
    WSY(1:NP)=WSY2(1:NP)
  endif
  if(.not.use_interface_wave_forcing) then
    RSNX(1:NP)=RSNX2(1:NP)
    RSNY(1:NP)=RSNY2(1:NP)
  endif
  if(.not.use_interface_tidal_forcing.AND.CTIP) TIP(1:NP)=TIP2(1:NP)
  ret=0
end function

function cleanup_code() result(ret)
  integer :: ret
  call ADCIRC_Final
  ret=0
end function

subroutine ADCIRC_allocate_interface_storage()
  if(allocated(ESBIN)) deallocate(ESBIN)
  if(allocated(FBQX)) deallocate(FBQX)
  if(allocated(FBQY)) deallocate(FBQY)
  if(allocated(WSX)) deallocate(WSX)
  if(allocated(WSY)) deallocate(WSY)
  if(allocated(RSNX)) deallocate(RSNX)
  if(allocated(RSNY)) deallocate(RSNY)
  if(allocated(TIP)) deallocate(TIP)
  if(allocated(DETA_DT)) deallocate(DETA_DT)
  if(allocated(PR)) deallocate(PR)
  allocate( ESBIN(MNETA) )
  allocate( FBQX(MNVEL),FBQY(MNVEL) )
  allocate( WSX(MNP),WSY(MNP), DETA_DT(MNP), PR(MNP) )
  allocate( RSNX(MNP),RSNY(MNP) )
  allocate( TIP(MNP) )
  ESBIN(:)=0.
  FBQX(:)=0.
  FBQY(:)=0.
  WSX(:)=0.
  WSY(:)=0.
  RSNX(:)=0.
  RSNY(:)=0.
  DETA_DT(:)=0.
  PR(:)=0.
  TIP(:)=0.

  if(allocated(AMUSE_LNM)) deallocate(AMUSE_LNM)
  if(allocated(AMUSE_RESSAL)) deallocate(AMUSE_RESSAL)
  if(allocated(AMUSE_RESTEMP)) deallocate(AMUSE_RESTEMP)
  if(allocated(AMUSE_HFLUX)) deallocate(AMUSE_HFLUX)
  allocate( AMUSE_LNM(MNETA) )
  allocate( AMUSE_RESSAL(MNETA, NFEN) )
  allocate( AMUSE_RESTEMP(MNETA, NFEN) )
  allocate( AMUSE_HFLUX(MNP) )
  AMUSE_LNM=0.
  AMUSE_RESSAL=0.
  AMUSE_RESTEMP=0.
  AMUSE_HFLUX=0.

end subroutine

function commit_parameters() result(ret)
  integer :: ret
  CALL ADCIRC_Init(ROOTD=ROOTDIR)
  call ADCIRC_allocate_interface_storage()
  ret=0
end function

function commit_grid() result(ret)
  integer :: ret
  integer :: i
  REAL(SZ) H2

  ETA1(1:NP)=ETA2(1:NP)-DTDP*DETA_DT(1:NP)

  DO I=1, NP
     ETAS(I)=ETA2(I)-ETA1(I)
     H2=DP(I)+IFNLFA*ETA2(I)
     QX2(I)=UU2(I)*H2
     QY2(I)=VV2(I)*H2
  END DO

  ret=0
end function

function recommit_parameters() result(ret)
 integer :: ret
 ret=-2
end function

function get_model_time(tout) result(ret)
  integer :: ret
  real(8) :: tout
  tout = STATIM*86400.D0+DTDP*(ITIME_BGN-1)
  ret=0
end function

function get_timestep(dtout) result(ret)
  integer :: ret
  real(8) :: dtout
  dtout = DTDP
  ret=0
end function

function get_use_interface_elevation_boundary(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_elevation_boundary
  ret=0
end function
function set_use_interface_elevation_boundary(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_elevation_boundary=flag
  ret=0
end function

function get_use_interface_flow_boundary(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_flow_boundary
  ret=0
end function
function set_use_interface_flow_boundary(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_flow_boundary=flag
  ret=0
end function

function get_use_interface_met_forcing(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_met_forcing
  ret=0
end function
function set_use_interface_met_forcing(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_met_forcing=flag
  ret=0
end function

function get_use_interface_wave_forcing(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_wave_forcing
  ret=0
end function
function set_use_interface_wave_forcing(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_wave_forcing=flag
  ret=0
end function

function get_use_interface_tidal_forcing(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_tidal_forcing
  ret=0
end function
function set_use_interface_tidal_forcing(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_tidal_forcing=flag
  ret=0
end function

function get_use_interface_surface_heat_forcing(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_surface_heat_forcing
  ret=0
end function
function set_use_interface_surface_heat_forcing(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_surface_heat_forcing=flag
  ret=0
end function

function get_use_interface_lnm_boundary(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_lnm_boundary
  ret=0
end function
function set_use_interface_lnm_boundary(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_lnm_boundary=flag
  ret=0
end function

function get_use_interface_salinity_boundary(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_salinity_boundary
  ret=0
end function
function set_use_interface_salinity_boundary(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_salinity_boundary=flag
  ret=0
end function

function get_use_interface_temperature_boundary(flag) result(ret)
  integer :: ret
  logical flag
  flag=use_interface_temperature_boundary
  ret=0
end function
function set_use_interface_temperature_boundary(flag) result(ret)
  integer :: ret
  logical flag
  use_interface_temperature_boundary=flag
  ret=0
end function

function get_node_eta(ind,eta2_) result(ret)
  integer :: ind,ret
  real*8 :: eta2_
  eta2_=ETA2(ind)
  if(NNODECODE(ind).EQ.0) then
    eta2_=-DP(ind)
  endif
  ret=0
end function

function get_node_vx(ind,uu2_) result(ret)
  integer :: ind,ret
  real*8 :: uu2_
  uu2_=UU2(ind)
  ret=0
end function

function get_node_vy(ind,vv2_) result(ret)
  integer :: ind,ret
  real*8 :: vv2_
  vv2_=VV2(ind)
  ret=0
end function

function get_node_eta_prev(ind,eta_) result(ret)
  integer :: ind,ret
  real*8 :: eta_
  eta_=ETA1(ind)
  ret=0
end function

function get_node_deta_dt(ind,x) result(ret)
  integer :: ind,ret
  real*8 :: x
  x=DETA_DT(ind)
  ret=0
end function

function get_node_status(ind,x) result(ret)
  integer :: ind,ret
  character(len=*) :: x
  if(NNODECODE(ind).EQ.0) then
    x="dry"
  else
    x="wet"
  endif
  ret=0
end function

function get_node_position(ind,x_,y_) result(ret)
  integer :: ind,ret
  real*8 :: x_,y_
  if(ind.LT.1.OR.ind.GT.NP) then
    ret=-1
    return
  endif
  x_=X(ind)
  y_=Y(ind)
  ret=0
end function
function get_node_coordinates(ind,lon_,lat_) result(ret)
  integer :: ind,ret
  real*8 :: lon_,lat_
  if(ind.LT.1.OR.ind.GT.NP) then
    ret=-1
    return
  endif
  lon_=SLAM(ind)
  lat_=SFEA(ind)
  ret=0
end function

function set_node_eta(ind,eta2_) result(ret)
  integer :: ind,ret
  real*8 :: eta2_

  ETA2(ind)=eta2_
  ret=0
end function
function set_node_vx(ind,uu2_) result(ret)
  integer :: ind,ret
  real*8 :: uu2_

  UU2(ind)=uu2_
  ret=0
end function
function set_node_vy(ind,vv2_) result(ret)
  integer :: ind,ret
  real*8 :: vv2_

  VV2(ind)=vv2_
  ret=0
end function
function set_node_eta_prev(ind,v1) result(ret)
  integer :: ind,ret
  real*8 :: v1
  ETA1(ind)=v1
  ret=0
end function
function set_node_deta_dt(ind,x) result(ret)
  integer :: ind,ret
  real*8 :: x
  DETA_DT(ind)=x
  ret=0
end function
function set_node_status(ind,v1) result(ret)
  integer :: ind,ret
  character(len=*) :: v1
  if(v1.EQ."wet") NNODECODE(ind)=1
  if(v1.EQ."dry") NNODECODE(ind)=0
  ret=0
end function

function get_node_depth(ind,dp_) result(ret)
  integer :: ind,ret
  real*8 :: dp_
  if(ind.LT.1.OR.ind.GT.NP) then
    ret=-1
    return
  endif
  dp_=DP(ind)
  ret=0
end function

function get_node_coriolis_f(ind,corif_) result(ret)
  integer :: ind,ret
  real*8 :: corif_
  corif_=CORIF(ind)
  ret=0
end function
function set_node_coriolis_f(ind,corif_) result(ret)
  integer :: ind,ret
  real*8 :: corif_
  CORIF(ind)=corif_
  ret=0
end function

function get_node_wind_stress(ind,wsx_,wsy_) result(ret)
  integer :: ind,ret
  real*8 :: wsx_,wsy_
  wsx_=WSX(ind)*RhoWat0
  wsy_=WSY(ind)*RhoWat0
  ret=0
end function
function set_node_wind_stress(ind,wsx_,wsy_) result(ret)
  integer :: ind,ret
  real*8 :: wsx_,wsy_
  WSX(ind)=wsx_/RhoWat0
  WSY(ind)=wsy_/RhoWat0
  ret=0
end function

function get_node_wave_stress(ind,wsx_,wsy_) result(ret)
  integer :: ind,ret
  real*8 :: wsx_,wsy_
  wsx_=RSNX(ind)*RhoWat0
  wsy_=RSNY(ind)*RhoWat0
  ret=0
end function
function set_node_wave_stress(ind,wsx_,wsy_) result(ret)
  integer :: ind,ret
  real*8 :: wsx_,wsy_
  RSNX(ind)=wsx_/RhoWat0
  RSNY(ind)=wsy_/RhoWat0
  ret=0
end function

function get_node_tidal_potential(ind,x_) result(ret)
  integer :: ind,ret
  real*8 :: x_
  x_=G*TIP(ind)
  ret=0
end function
function set_node_tidal_potential(ind,x_) result(ret)
  integer :: ind,ret
  real*8 :: x_
  TIP(ind)=x_/G
  ret=0
end function

function get_node_atmospheric_pressure(ind,x) result(ret)
  integer :: ind,ret
  real*8 :: x
  x=PR(ind)+reference_pressure
  ret=0
end function
function set_node_atmospheric_pressure(ind,x) result(ret)
  integer :: ind,ret
  real*8 :: x
  PR(ind)=x-reference_pressure
  ret=0
end function

function get_node_surface_heat_flux(ind,hflux_) result(ret)
  integer :: ind,ret
  real*8 :: hflux_
  hflux_=AMUSE_HFLUX(ind)
  ret=0
end function
function set_node_surface_heat_flux(ind,hflux_) result(ret)
  integer :: ind,ret
  real*8 :: hflux_
  AMUSE_HFLUX(ind)=hflux_
  ret=0
end function

function get_node_sigma(ind,indz,s_,z_) result(ret)
  integer :: ind,indz,ret
  real*8 :: s_,z_
  real*8, parameter :: a=1,b=-1
  if(ind.LT.1.OR.ind.GT.NP) then
    ret=-1
    return
  endif
  if(indz.LT.1.OR.indz.GT.NFEN) then
    ret=-1
    return
  endif
  s_=SIGMA(indz)
  z_=(s_-a)/(a-b)*(DP(ind)+ETA2(ind))+ETA2(ind)
  ret=0
end function

function get_node_velocities_3d(ind,indz,vx_,vy_,vz_) result(ret)
  integer :: ind,indz,ret
  real*8 :: vx_,vy_,vz_
  if(ind.LT.1.OR.ind.GT.NP) then
    ret=-1
    return
  endif
  if(indz.LT.1.OR.indz.GT.NFEN) then
    ret=-1
    return
  endif
  vx_=REAL(Q(ind,indz))
  vy_=IMAG(Q(ind,indz))
  vz_=WZ(ind,indz)
  ret=0
end function

function get_node_temperature_3d(ind,indz,temp_) result(ret)
  integer :: ind,indz,ret
  real*8 :: temp_
  if(ind.LT.1.OR.ind.GT.NP) then
    ret=-1
    return
  endif
  if(indz.LT.1.OR.indz.GT.NFEN) then
    ret=-1
    return
  endif
  temp_=TEMP(ind,indz)
  ret=0
end function

function get_element_nodes(ind,n1,n2,n3) result(ret)
  integer :: ind,n1,n2,n3,ret
  if(ind.LT.1.OR.ind.GT.NE) then
    ret=-1
    return
  endif
  n1=NM(ind,1)-1
  n2=NM(ind,2)-1
  n3=NM(ind,3)-1
  ret=0
end function

function get_element_status(ind,x) result(ret)
  integer :: ind,ret
  character(len=*) :: x
  if(NOFF(ind).EQ.0) then
    x="dry"
  else
    x="wet"
  endif
  ret=0
end function

function set_element_status(ind,v1) result(ret)
  integer :: ind,ret
  character(len=*) :: v1
  if(v1.EQ."wet") NOFF(ind)=1
  if(v1.EQ."dry") NOFF(ind)=0
  ret=0
end function

function get_element_position(ind,x_,y_) result(ret)
  integer :: ind,n1,n2,n3,ret
  real*8 :: x_,y_

  if(ind.LT.1.OR.ind.GT.NE) then
    ret=-1
    return
  endif
  n1=NM(ind,1)
  n2=NM(ind,2)
  n3=NM(ind,3)
  x_=(X(n1)+X(n2)+X(n3))/3
  y_=(Y(n1)+Y(n2)+Y(n3))/3
  ret=0
end function
function get_element_coordinates(ind,lon_,lat_) result(ret)
  integer :: ind,n1,n2,n3,ret
  real*8 :: lon_,lat_

  if(ind.LT.1.OR.ind.GT.NE) then
    ret=-1
    return
  endif
  n1=NM(ind,1)
  n2=NM(ind,2)
  n3=NM(ind,3)
  lon_=(SLAM(n1)+SLAM(n2)+SLAM(n3))/3
  lat_=(SFEA(n1)+SFEA(n2)+SFEA(n3))/3
  ret=0
end function

function get_number_of_nodes(nout) result(ret)
  integer :: ret,nout
  nout=NP
  ret=0
end function

function get_number_of_elements(nout) result(ret)
  integer :: ret,nout
  nout=NE
  ret=0
end function

function get_number_of_elevation_boundary_segments(nout) result(ret)
  integer :: ret, nout
  nout=NOPE
  ret=0
end function

function get_number_of_nodes_in_elevation_boundary_segment(iseg,nout) result(ret)
  integer :: ret, iseg, nout
  nout=NVDLL(iseg)
  ret=0
end function

function get_elevation_boundary_node(inode,iseg,index_node) result(ret)
  integer :: ret, inode,iseg,index_node
  index_node=NBDV(iseg,inode)-1
  ret=0
end function

function get_elevation_boundary_eta(inode,iseg,eta) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: eta
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
  eta=ESBIN(i)
  ret=0
end function

function set_elevation_boundary_eta(inode,eta,iseg) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: eta
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
  ESBIN(i)=eta
  ret=0
end function

function get_flow_boundary_fluxx(inode,iseg,vx) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: vx
  i=sum(NVELL(1:iseg-1))+inode
  if(NBV(i).NE.NBVV(iseg,inode)) then
    ret=-1
    return
  endif
  vx=FBQX(i)
  ret=0
end function

function set_flow_boundary_fluxx(inode,vx,iseg) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: vx
  i=sum(NVELL(1:iseg-1))+inode
  if(NBV(i).NE.NBVV(iseg,inode)) then
    ret=-1
    return
  endif
  if(LBCODEI(i).NE.2.AND.LBCODEI(i).NE.12.AND.LBCODEI(i).NE.22) then
    ret=-2
    return
  endif
  FBQX(i)=vx
  ret=0
end function

function get_flow_boundary_fluxy(inode,iseg,vy) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: vy
  i=sum(NVELL(1:iseg-1))+inode
  if(NBV(i).NE.NBVV(iseg,inode)) then
    ret=-1
    return
  endif
  vy=FBQY(i)
  ret=0
end function

function set_flow_boundary_fluxy(inode,vy,iseg) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: vy
  i=sum(NVELL(1:iseg-1))+inode
  if(NBV(i).NE.NBVV(iseg,inode)) then
    ret=-1
    return
  endif
  if(LBCODEI(i).NE.2.AND.LBCODEI(i).NE.12.AND.LBCODEI(i).NE.22) then
    ret=-2
    return
  endif
  FBQY(i)=vy
  ret=0
end function

function get_boundary_lnm(inode,iseg,x_) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: x_
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
  x_=AMUSE_LNM(i)
  ret=0
end function

function set_boundary_lnm(inode,x_,iseg) result(ret)
  integer :: ret, inode,iseg,i
  real*8 :: x_
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
 AMUSE_LNM(i)=x_
  ret=0
end function

function get_boundary_salinity(inode,zind,iseg,x_) result(ret)
  integer :: ret, inode,iseg,i,zind
  real*8 :: x_
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
  if(zind.LT.1.OR.zind.GT.NFEN) then
    ret=-2
    return
  endif
  x_=AMUSE_RESSAL(i,zind)
  ret=0
end function

function set_boundary_salinity(inode,zind,x_,iseg) result(ret)
  integer :: ret, inode,iseg,i,zind
  real*8 :: x_
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
  if(zind.LT.1.OR.zind.GT.NFEN) then
    ret=-2
    return
  endif
  AMUSE_RESSAL(i,zind)=x_
  ret=0
end function

function get_boundary_temperature(inode,zind,iseg,x_) result(ret)
  integer :: ret, inode,iseg,i,zind
  real*8 :: x_
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
  if(zind.LT.1.OR.zind.GT.NFEN) then
    ret=-2
    return
  endif
  x_=AMUSE_RESTEMP(i,zind)
  ret=0
end function

function set_boundary_temperature(inode,zind,x_,iseg) result(ret)
  integer :: ret, inode,iseg,i,zind
  real*8 :: x_
  i=sum(NVDLL(1:iseg-1))+inode
  if(NBD(i).NE.NBDV(iseg,inode)) then
    ret=-1
    return
  endif
  if(zind.LT.1.OR.zind.GT.NFEN) then
    ret=-2
    return
  endif
  AMUSE_RESTEMP(i,zind)=x_
  ret=0
end function

function get_number_of_flow_boundary_segments(nout) result(ret)
  integer :: ret, nout
  nout=NBOU
  ret=0
end function

function get_number_of_nodes_in_flow_boundary_segment(iseg,nout) result(ret)
  integer :: ret, iseg, nout
  nout=NVELL(iseg)
  ret=0
end function

function get_flow_boundary_node(inode,iseg,index_node) result(ret)
  integer :: ret, inode,iseg,index_node
  index_node=NBVV(iseg,inode)-1
  ret=0
end function

function get_flow_boundary_type(inode,iseg,type_) result(ret)
  integer :: ret, inode,iseg,type_
  if(IBTYPE(iseg).NE.LBCODEI(NBVV(iseg,inode))) then
   ret=-1
   return
  endif
  type_=IBTYPE(iseg)
  ret=0
end function

function get_number_of_vertical_nodes(nout) result(ret)
  integer :: ret,nout
  nout=NFEN
  ret=0
end function

function get_reference_pressure(x) result(ret)
  integer :: ret
  real*8 :: x
  x=reference_pressure
  ret=0
end function

end module


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS      !
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!BOP
! !ROUTINE: ods_do3lev
!
! !INTERFACE:
!
      subroutine ods_do3lev ( var, data, ninfo, nobs,
     .                       ods,  mobs, kobs, iks, rc )

      use m_odsmeta
      use m_ods
      use m_ods_obsdiags, only : ods_obsdiags
      use m_ods_obsdiags, only : ods_obsdiags_getparam

      implicit NONE

! !INPUT PARAMETERS:

      integer,          intent(in)    :: mobs         ! max obs in ODS array
      integer,          intent(in)    :: ninfo, nobs  ! data dims
      real(4),          intent(in)    :: data(ninfo,nobs)
      character(len=*), intent(in)    :: var          ! obs type

! !INPUT/OUTPUT PARAMETERS:

      integer,          intent(inout) :: kobs, iks
      type(ods_vect),   intent(inout) :: ods

! !OUTPUT PARAMETERS:

      integer,          intent(out)   :: rc

! !DESCRIPTION: Converts ozone level data from GSI diag_ files to ODS.
!
! !REVISION HISTORY:
!	4Jan2007 - Sienkiewicz   Initial code
!       9Apr2008 - Sienkiewicz   modified for new GSI-2006
!
!EOP
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      character(len=*), parameter :: myname = 'ods_do3lev'

      integer, parameter   :: r_single = selected_real_kind(6)
      real(r_single)  zero_single,tiny_single
      real small_num

      integer i, iu, iv, kobs0, ks0

      real, parameter :: undef = 1.e15

      logical lobsdiagsave

!     Pointers to ods attributes:
!     --------------------------
      integer, pointer :: kt(:)       ! data type index
      integer, pointer :: kx(:)       ! data source index
      integer, pointer :: ks(:)       ! sounding index
      real   , pointer :: lon(:)      ! longitude of obs (degrees)
      real   , pointer :: lat(:)      ! latitude of obs (degrees)
      real   , pointer :: lev(:)      ! pressure level of obs (hPa)
      integer, pointer :: time(:)     ! time
      real   , pointer :: obs(:)      ! observation
      real   , pointer :: OmF(:)      ! obs-minus-fcst (O-F)
      real   , pointer :: OmA(:)      ! obs-minus-ana  (O-A)
      real   , pointer :: sigo(:)     ! obs error std dev
      real   , pointer :: xm(:)       ! metadata
      integer, pointer :: qcx(:)      ! exclusion mark
      integer, pointer :: qch(:)      ! history mark

!     Assign pointers to ODS attributes
!     ---------------------------------
      kt   => ods%data%kt
      kx   => ods%data%kx
      ks   => ods%data%ks
      lon  => ods%data%lon
      lat  => ods%data%lat
      lev  => ods%data%lev
      time => ods%data%time
      obs  => ods%data%obs
      OmF  => ods%data%OmF
      OmA  => ods%data%OmA
      sigo => ods%data%Xvec
      xm   => ods%data%xm
      qcx  => ods%data%qcexcl
      qch  => ods%data%qchist

      tiny_single = tiny(zero_single)
      small_num = 1.e3 * tiny_single

      rc = 0  ! all is well to start with

      call ods_obsdiags_getparam ( 'lobsdiagsave', lobsdiagsave )

      kobs0 = kobs

      ks0 = data(11,1)

      do i = 1, nobs

         kobs         = kobs + 1
         if(kobs>mobs) then
            rc = 99
            print *, myname, 'dim violation, var = ', var
            exit
         endif
         kt(kobs)     = kto3
         kx(kobs)     = nint(data(1,i))

         lat(kobs)    = data(2,i)
         lon(kobs)    = data(3,i)
         lev(kobs)    = data(4,i)
         time(kobs)   = data(5,i) * 60 ! convert to minutes from ana time
         obs(kobs)    = data(8,i)             ! obs
         omf(kobs)    = (data(8,i)-data(9,i)) ! omf
         oma(kobs)    = undef   ! no info available
         xm(kobs)     = data(13,i)       ! try quality flag

         qch(kobs)    = 0       ! no info available
         qcx(kobs)    = 0

         if (data(15,i) < 0. .or. data(15,i) >= 100. ) then
            qcx(kobs) = X_PASSIVE
         endif

         if (data(7,i)>small_num) then
            sigo(kobs) = 1./data(7,i)                ! sigo
            if(data(6,i)<1) qcx(kobs) = X_NCEP_NLNQC
         else                                         ! rejected by QC
            sigo(kobs) = undef
            qcx(kobs) = 2
         endif

         if (data(11,i) /= ks0 ) then    ! check sounding index
            iks = iks + 1
            ks0 = data(11,i)
         endif

         ks(kobs)     = iks

c$$$         weight(kobs) = data(6,i) ! fractional weight

      end do

!     Nullify pointers
!     -----------------
      if(associated(lat)   ) nullify(lat)
      if(associated(lon)   ) nullify(lon)
      if(associated(lev)   ) nullify(lev)
      if(associated(time)  ) nullify(time)
      if(associated(kt)    ) nullify(kt)
      if(associated(kx)    ) nullify(kx)
      if(associated(ks)    ) nullify(ks)
      if(associated(xm)    ) nullify(xm)
      if(associated(qch)   ) nullify(qch)
      if(associated(qcx)   ) nullify(qcx)
      if(associated(obs)   ) nullify(obs)
      if(associated(omf)   ) nullify(omf)
      if(associated(oma)   ) nullify(oma)
      if(associated(sigo)  ) nullify(sigo)

      end subroutine ods_do3lev


subroutine lfm_initpts(lfmprd_dir,a24time,a9time)

!GFORTRAN additions begin
include 'trigd.inc'
!GFORTRAN additions end
use lfmgrid

implicit none

integer :: npt,nestpt,nc,chr,i,m
integer :: ptpcptype
real :: ptlat,ptlon,pti,ptj,ptzsfc,pttsfc,pttdsfc,ptrhsfc      &
       ,ptusfc,ptvsfc,ptspd,ptdir,ptupbl,ptvpbl,ptbspd,ptbdir  &
       ,ptceiling,ptvis,ptcld,ptpcp,ptsnow,ptvnt,ptpbl
character(len=256) :: lfmprd_dir,ptfile,outfile
character(len=80) :: customer
character(len=32) :: cmtype
character(len=24) :: a24time
character(len=16) :: date_str
character(len=10) :: ptid
character(len=9) :: a9time
character(len=8) :: ptwx
character(len=3) :: domnum_str
character(len=2) :: amonth
logical :: back=.true.,there

character(len=3) :: amonths(12)
data amonths/'JAN','FEB','MAR','APR','MAY','JUN'  &
            ,'JUL','AUG','SEP','OCT','NOV','DEC'/

! Prepare date/time string.

do m=1,12
   if (a24time(4:6) == amonths(m)) exit
enddo
write(amonth,'(i2.2)') m

date_str=amonth//'/'//a24time(1:2)//'/'//a24time(8:11)//' '//a24time(13:17)

! Read point forecast file.
! Compute i,j locations of output point forecast locations in native grid.
! Remove any stations outside of output domain.
! Write point text file to model directory.

nc=index(filename,'/',back)
if (nc > 1) nc=index(filename(1:nc-1),'/',back)
ptfile=lfmprd_dir(1:nc)//'static/lfmpost_points.txt'
inquire(file=trim(ptfile),exist=there)
if (.not. there) then
   print*,' '
   print*,'Could not find point forecast location file: ',trim(ptfile)
   npt=0
   return
endif

if (verbose) then
   print*,' '
   print*,'Reading points from: ',trim(ptfile)
endif

open(1,file=trim(ptfile),status='old',form='formatted',access='sequential')
npt=0
do while(.true.)
   read(1,'(i2,1x,a10,1x,f8.4,1x,f9.4,1x,a)',end=1) nestpt,ptid,ptlat,ptlon,customer
   if (nestpt == domnum) then
      call latlon_to_ij(proj,ptlat,ptlon,pti,ptj)
      if (pti >= 1. .and. pti <= lx .and. &
          ptj >= 1. .and. pti <= ly) then
         npt=npt+1
         call gdtost_lfm(zsfc,lx,ly,pti,ptj,ptzsfc)
         call gdtost_lfm(tsfc,lx,ly,pti,ptj,pttsfc)
         call gdtost_lfm(tdsfc,lx,ly,pti,ptj,pttdsfc)
         if (point_temp_units == 'F') then
            pttsfc=(pttsfc-273.15)*1.8+32.
            pttdsfc=(pttdsfc-273.15)*1.8+32.
         elseif (point_temp_units == 'C') then
            pttsfc=pttsfc-273.15
            pttdsfc=pttdsfc-273.15
         endif
         call gdtost_lfm(rhsfc,lx,ly,pti,ptj,ptrhsfc)
         call gdtost_lfm(usfc,lx,ly,pti,ptj,ptusfc)
         call gdtost_lfm(vsfc,lx,ly,pti,ptj,ptvsfc)
         ptspd=(ptusfc**2+ptvsfc**2)**0.5
         ptdir=atan2d(-ptusfc,-ptvsfc)
         if (ptdir < 0.) ptdir=ptdir+360.
         if (make_firewx) then
            call gdtost_lfm(upbl,lx,ly,pti,ptj,ptupbl)
            call gdtost_lfm(vpbl,lx,ly,pti,ptj,ptvpbl)
            ptbspd=(ptupbl**2+ptvpbl**2)**0.5
            ptbdir=atan2d(-ptupbl,-ptvpbl)
            if (ptbdir < 0.) ptbdir=ptbdir+360.
         else
            ptbspd=0.
            ptbdir=999.
         endif
         if (point_windspd_units == 'KTS') then
            ptspd=ptspd*1.9425
            if (make_firewx) ptbspd=ptbspd*1.9425
         elseif (point_windspd_units == 'MPH') then
            ptspd=ptspd*2.2369
            if (make_firewx) ptbspd=ptbspd*2.2369
         endif
         call gdtost_lfm(ceiling,lx,ly,pti,ptj,ptceiling)
         if (ptceiling < 50000.) then
            ptceiling=ptceiling*.032808  ! Hundreds of feet
         else
            ptceiling=999.
         endif
         call gdtost_lfm(visibility,lx,ly,pti,ptj,ptvis)
         ptvis=ptvis*0.00062317  ! Miles
         call gdtost_lfm(cldamt,lx,ly,pti,ptj,ptcld)
         call gdtost_lfm(pcp_inc,lx,ly,pti,ptj,ptpcp)
         ptpcp=ptpcp*39.27
         call gdtost_lfm(snow_inc,lx,ly,pti,ptj,ptsnow)
         ptsnow=ptsnow*39.27
         call gdtost_lfm(vnt_index,lx,ly,pti,ptj,ptvnt)
         ptvnt=max(0.,ptvnt)
         if (point_vent_units == 'KT-FT') ptvnt=ptvnt*6.3774
         call gdtost_lfm(pblhgt,lx,ly,pti,ptj,ptpbl)
         ptpbl=max(0.,ptpbl)
         ptpbl=ptpbl*3.28

         ptpcptype=nint(pcptype_sfc(nint(pti),nint(ptj)))
         select case (ptpcptype)
         case (0)
            if (ptvis >= 7.) then
               if (ptcld >= 0.75) then
                  ptwx='CLOUDY  '
               elseif (ptcld < 0.75 .and. ptcld >= 0.25) then
                  ptwx='PT CLDY '
               else
                  ptwx='CLEAR   '
               endif
            elseif (ptvis < 7. .and. ptvis >= 3.) then
               ptwx='HAZE    '
            else
               ptwx='FOG     '
            endif
         case (1)
            ptwx='RAIN    '
         case (2)
            ptwx='SNOW    '
         case (3)
            ptwx='FRZRAIN '
         case (4)
            ptwx='SLEET   '
         case (5)
            ptwx='HAIL    '
         case (6)
            ptwx='DRIZZLE '
         case (7)
            ptwx='MIXED   '
         case (8)
            ptwx='MIXED   '
         case (9)
            ptwx='RAIN/ICE'
         case default
            ptwx='UNKNOWN '
         end select

         write(domnum_str,'("d",i2.2)') domnum
         outfile=trim(lfmprd_dir)//'/'//domnum_str//'/points/'//trim(ptid)//'_'//a9time//'_fcst.txt'
         inquire(file=trim(outfile),exist=there)
         if (fcsttime == 0) there=.false.
         if (there) then
            open(2,file=trim(outfile),form='formatted',status='old',position='append')
         else
            cmtype=mtype
            do i=1,len_trim(cmtype)
               chr=ichar(cmtype(i:i))
               if (chr > 96 .and. chr < 123) cmtype(i:i)=char(chr-32)
            enddo

            open(2,file=trim(outfile),form='formatted',status='new')
            write(2,'("**********************************************************************************************")')
            write(2,'("LOCATION: ",a,2x,"LAT: ",f8.4,2x,"LON: ",f9.4,2x,"I: ",f7.2,2x,"J: ",f7.2)')  &
                  ptid,ptlat,ptlon,pti,ptj
            write(2,'(a4,f4.1," km    FORECAST CYCLE: ",a,2x,"DOM: ",i2,2x,"MODEL ELEVATION: ",i4)')  &
                  cmtype(1:4),grid_spacing/1000.,a9time,domnum,nint(ptzsfc)
            write(2,'("**********************************************************************************************")')
            write(2,'("DATE       TIME  TMP DPT RH  WIND   CEI VIS  WEATHER  PRECP SNOW VENT   MIXHT PBLWND HM HH Fbg")')
            write(2,'(A3,8x,A3,3x,A1,3x,A1,3x,"%",3x,"Dg@",A3,1x,"hft mile",10x,"in",4x,"in",3x,A5,2x,"FtAGL",1x,"Dg@",A3)') &
                  point_tz_label,point_tz_label,point_temp_units  &
                 ,point_temp_units,point_windspd_units,point_vent_units,point_windspd_units
            write(2,'("---------- ----- --- --- --- ------ --- ---- -------- ----- ---- ------ ----- ------ -- -- ---")')
         endif

         write(2,'(a,3i4,1x,i3.3,"/",i2.2,1x,i3.3,1x,f4.1,1x,a,1x,f5.2,1x,f4.1,1x,i6,1x,i5,1x,i3.3,"/",i2.2,1x,i2,1x,i2,1x,i3)') &
               date_str,nint(pttsfc),nint(pttdsfc),nint(ptrhsfc),nint(ptdir/10.)*10,nint(ptspd)  &
              ,nint(ptceiling),ptvis,ptwx,ptpcp,ptsnow,nint(ptvnt),nint(ptpbl)                   &
              ,nint(ptbdir/10.)*10,nint(ptbspd),nint(ham_index(nint(pti),nint(ptj)))             &
              ,nint(hah_index(nint(pti),nint(ptj))),nint(fwi_index(nint(pti),nint(ptj)))
         close(2)
      endif
   endif
enddo
1 continue

return
end