TEXT   19

weightsEvol.f90

Guest on 24th May 2021 07:55:46 PM

  1. != weightsEvol.f90 07Sep2017 (2014) Weights in interval
  2. ! ... Keywords: weights interval
  3. ! . WARNING: new version of 'w3g_plot.f90' needed to accept TEXT.
  4.  CALL timer; WRITE (*, "(' *** ', A, ' ***', T68, '(', A8, ', MC)' / T72, A)") &
  5.       'Weights in interval', 'Sep-2017', '[07_21:04]'
  6.  CALL mainsub; CALL timer; STOP
  7.  END
  8.  
  9.  SUBROUTINE mainsub
  10. ! ... Weights ..........................................................
  11.  IMPLICIT DOUBLE PRECISION (a-h, o-z)
  12.  CHARACTER hfileaux*1024, hxg*10 ! yyyy/mm/dd (10 chars)
  13.  ALLOCATABLE xg(:), hxg(:), zg(:,:)
  14.  CALL readat (hfileaux, iyear_beg, month_beg, iyear_end, month_end, &
  15.       height, wref, ishow)
  16.  CALL tempfile_F (itempfile, 'on')
  17.  CALL manage_data (TRIM(hfileaux), itempfile, &
  18.       iyear_beg, month_beg, iyear_end, month_end, nrec)
  19.  WRITE (*, 96200) nrec
  20. 96200 FORMAT (' Records read,', T32, I6, T42, '|')
  21.  CALL compute (itempfile, nrec, wref, height)
  22.  nz = 4; nmin = 1; nmax = nrec
  23.  ALLOCATE (xg(nmin:nmax), hxg(nmin:nmax), zg(nz,nmin:nmax))
  24.  xg = 0
  25.  REWIND (itempfile)
  26.  DO i=1, nrec; READ (itempfile, "(A10, 3F5.1, F5.2)") &
  27.       hxg(i), (zg(k,i), k=1, nz)
  28.  END DO
  29.  CALL tempfile_F (itempfile, 'off')
  30.  CALL www_graph (ishow, nmin, nmax, nz, xg, hxg, zg)
  31.  RETURN
  32.  END SUBROUTINE !END!
  33.  
  34.  INCLUDE 'timer.f90'
  35.  INCLUDE 'internet.f90'
  36.  INCLUDE 'tempfile17.f90'
  37.  INCLUDE 'error.f90'
  38.  INCLUDE './w3g_plot.f90'
  39.  SUBROUTINE manage_data (hfileaux, itempfile, &
  40.       iyear_beg, month_beg, iyear_end, month_end, nrec)
  41. ! ... ..................................................................
  42.  IMPLICIT DOUBLE PRECISION (a-h, o-z)
  43.  CHARACTER hfileaux*(*), hrow*128, hrow_vec*128
  44.  ALLOCATABLE hrow_vec(:)
  45.  itt = itempfile + 1
  46.  OPEN (itt, FILE=TRIM(hfileaux), STATUS='OLD')
  47. ! ... Copy to 'itempfile'
  48.  nrec = 0
  49.  DO; READ (itt, "(A)", END=9100) hrow
  50.     READ (hrow, "(I4, 2(1X, I2))") iyear, month, iday
  51.     idate = iyear * 10000 + month * 100 + iday
  52.     IF (iyear < iyear_beg .OR. iyear > iyear_end) CYCLE
  53.     IF (month < month_beg .OR. month > month_end) CYCLE
  54.     nrec = nrec + 1
  55.     WRITE (itempfile, "(A)") TRIM(ADJUSTL(hrow))
  56.  END DO
  57. 9100 CONTINUE
  58.  CLOSE (itt)
  59.  IF (nrec < 1) CALL error ('No records.')
  60.  ALLOCATE (hrow_vec(nrec))
  61.  REWIND (itempfile)
  62.  DO i=1, nrec; READ (itempfile, "(A)") hrow_vec(i)
  63.  END DO
  64.  CALL sort_ascend (nrec, hrow_vec)
  65.  REWIND (itempfile)
  66.  DO i=1, nrec; WRITE (itempfile, "(A)") hrow_vec(i)
  67.  END DO
  68.  RETURN
  69.  END SUBROUTINE !END!
  70.  
  71.  SUBROUTINE sort_ascend (nn, hrow_vec)
  72. ! ... ..................................................................
  73.  CHARACTER hrow_vec*(*), htemp*1024
  74.  DIMENSION hrow_vec(nn)
  75.  leng = MAXVAL(LEN_TRIM(hrow_vec))
  76.  DO; ichange = 0
  77.     DO i=2, nn
  78.        IF (LLT(hrow_vec(i)(:10), hrow_vec(i-1)(:10))) THEN
  79.           htemp(:leng) = hrow_vec(i-1); hrow_vec(i-1) = hrow_vec(i)
  80.           hrow_vec(i) = htemp(:leng); ichange = 1
  81.        END IF
  82.     END DO; IF (ichange == 0) EXIT
  83.  END DO
  84.  RETURN
  85.  END !END!
  86.  
  87.  SUBROUTINE compute (itempfile, nrec, wref, height)
  88. ! ... Re-format data in 'itempfile' for gnuplot ........................
  89.  IMPLICIT DOUBLE PRECISION (a-h, o-z)
  90.  CHARACTER hh*128, hrow_vec*128
  91.  ALLOCATABLE hrow_vec(:)
  92.  DATA fat_base/ 19.25 /
  93. ! ... Data from 'itempfile' to temporary vector
  94.  REWIND (itempfile)
  95.  wmin = HUGE(wmin); wmax = -wmin
  96.  average = 0; stdev = 0
  97.  ALLOCATE (hrow_vec(nrec))
  98.  READ (itempfile, "(A10, 2G5.1)") hh, weight, fat
  99.  IF (fat <= 0) fat = fat_base; fat_old = fat
  100.  WRITE (hrow_vec(1), 97150) &
  101.       TRIM(hh), wref, weight, weight/height**2, fat
  102.  wmin = MIN(wmin, weight); wmax = MAX(wmax, weight)
  103.  average = average + weight
  104.  stdev = stdev + weight*weight
  105.  DO i=2, nrec; READ (itempfile, "(A10, 2G5.1)") hh, weight, fat
  106.     IF (fat <= 0) fat = fat_old; fat_old = fat
  107.     WRITE (hrow_vec(i), 97150) &
  108.          TRIM(hh), wref, weight, weight/height**2, fat
  109. 97150 FORMAT (A10, F5.1, F5.1, F5.1, F6.2, ' %')
  110.     wmin = MIN(wmin, weight); wmax = MAX(wmax, weight)
  111.     average = average + weight
  112.     stdev = stdev + weight*weight
  113.  END DO
  114. ! ... Data back to the temporary file ('itempfile')
  115.  REWIND (itempfile)
  116.  DO i=1, nrec; WRITE (itempfile, "(A)") TRIM(hrow_vec(i))
  117.  END DO
  118.  DEALLOCATE (hrow_vec)
  119. ! ... var = {Sum(x^2) - [Sum(x)]^2/n}/(n-1)
  120.  stdev = SQRT((stdev - average*average/nrec)/(nrec-1))
  121.  average = average / nrec
  122.  sig_L = (wmin - average) / stdev
  123.  sig_R = (wmax - average) / stdev
  124.  WRITE (*, 98910) wmin, wmax, sig_L, sig_R, average, stdev
  125. 98910 FORMAT (T42, '|' / ' Min, max,', T18, 1P, 2G12.4, T42, &
  126.            '| sigmas (left, right),', 0P, 2F6.2 / &
  127.            ' Average, stdev,', T18, 1P, 2G12.4, T42, '|')
  128.  RETURN
  129.  END !END!
  130.  
  131.  SUBROUTINE readat (hfileaux, iy_beg, mo_beg, iy_end, mo_end, &
  132.       height, wref, ishow)
  133. ! ... ..................................................................
  134.  IMPLICIT DOUBLE PRECISION (a-h, o-z)
  135.  CHARACTER hfileaux*(*)
  136.  CALL reminder; CALL internet (inet)
  137.  READ (*, "(A)") hfileaux; hfileaux = ADJUSTL(hfileaux)
  138.  WRITE (*, 96220) "'" // TRIM(hfileaux) // "'"
  139. 96220 FORMAT (' Weights file,', T16, A23, T42, '|')
  140.  READ (*, *) iy_beg, mo_beg, iy_end, mo_end
  141.  WRITE (*, 96340) iy_beg, mo_beg, iy_end, mo_end
  142. 96340 FORMAT (' Year, month,', T18, 2(3X, I4, '/', I2.2), T42, &
  143.            '| (from, to)')
  144.  READ (*, *) height; WRITE (*, 97100) height, 22.5*height**2
  145. 97100 FORMAT (' Height, H (m),', T33, F5.2, &
  146.            T42, '| (bmi = W / H^2)', T63, 'Recomm. w.,', F5.1, ' kg')
  147.  READ (*, *) wref; WRITE (*, 97300) wref
  148. 97300 FORMAT (' W. reference (kg),', T33, F5.1, T42, '|')
  149.  READ (*, *) ishow; WRITE (*, 98900) ishow
  150. 98900 FORMAT (' Show coord.s ?', T36, I2, T42, &
  151.            '| (0|1: no|yes)' / 1X, 20('--'), '+-', 19('--'))
  152.  RETURN
  153.  END SUBROUTINE !END!
  154.  
  155.  SUBROUTINE reminder
  156. ! ... Tells basic information on data to supply ........................
  157. ! ... Keywords: reminder information user manual
  158.  CHARACTER arg*1024 ! narg = IARGC() ! older spelling
  159.  narg = COMMAND_ARGUMENT_COUNT() ! f-2003
  160.  IF (narg < 1) RETURN
  161.  CALL GETARG (1, arg); IF (TRIM(arg) /= '?') RETURN
  162.  WRITE (*, 97500); STOP
  163. 97500 FORMAT (' ~~~ ', "Weights" / &
  164.            5X, "Data: weights file", ' ~~~')
  165.  END !END!

Raw Paste


Login or Register to edit or fork this paste. It's free.